perm filename LIBPAS.PAS[PAS,SYS] blob
sn#576256 filedate 1981-03-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00039 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 (*$E+,S1200,T-
C00010 00003 PROGRAM ccl, option, getoption, getfilename, askfilename, startfile, getparameter, getnextcall, reenter
C00015 00004 TYPE
C00019 00005 (** insert ENTER_SWITCH **)
C00021 00006 (** GETFILENAME RE_INITIALIZE INITIALIZE READCHAR READOCTAL READDECIMAL SETSTATUS READSWITCH OPERAND NEXTCH ASSIGNFILENAMEOREXTENSION **)
C00035 00007 (** GETPARAMETER ASKFILENAME STARTFILE INITIALIZE **)
C00046 00008 (** OPTION FIND_SWITCH GETOPTION PICTURE **)
C00053 00009 PROGRAM ddt, debug
C00064 00010 VAR
C00068 00011 (** DEBUG [ SYSTEM_ERROR ERROR NEWLINE LENGTH **)
C00070 00012 (** INSYMBOL NEXTCH **)
C00079 00013 (** ACRPOINT TESTGLOBALBASIS IDTREE FIRSTBASIS SUCCBASIS SEARCHSECTION SEARCHID **)
C00083 00014 (** GETBOUNDS COMPTYPES **)
C00088 00015 (** NEXTBYTE PUTNEXTBYTE **)
C00090 00016 (** LOAD GETFIELD SELECTOR **)
C00098 00017 (** VARIABLE **)
C00101 00018 (** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)
C00106 00019 (** SHIFTED_OUT WRITESCALAR PUTSIXBIT **)
C00111 00020 (** WRITESTRUCTURE WRITEFIELDLIST **)
C00126 00021 (** ASSIGNMENT **)
C00128 00022 (** STOPSEARCH PAGEVALUE LINEVALUE BREAKPOINT GETLINPAG **)
C00136 00023 (** LINEINTERVAL STOPMESSAGE TRACEOUT ONE_VAR_OUT **)
C00140 00024 (** SECTION_OUT OUT **)
C00145 00025 (** STACK_OUT HEAP_OUT **)
C00149 00026 (** WRITE_PROGRAM_NAME HEADER BACK_TO_TTY CORRECT_ADDR RIGHT_ADDR **)
C00153 00027 (** INIT DEBUG_INTERACTIVE **)
C00160 00028 (** DEBUG_BATCH ] DEBUG **)
C00163 00029 PROGRAM status, getstatus
C00166 00030 PROGRAM read, readscalar, readirange,
C00173 00031 (** STOP ERROR NEXTCH SKIP READIRANGE READCRANGE READRRANGE **)
C00179 00032 (** READSCALAR READIDENTIFIER READSET **)
C00188 00033 (** READISET READCSET READDSET **)
C00193 00034 PROGRAM write, wrtscalar, wrtiset, wrtcset, wrtdset
C00196 00035 (** WRTSCALAR WRTSET WRTISET WRTCSET WRTDSET **)
C00201 00036 PROGRAM timing, setruntime, setelapsedtime, settime, runtime, elapsedtime,
C00207 00037 PROGRAM strings, assign, length, pos, substr, concat, getchr, putchar,
C00230 00038 PROGRAM dumper, dpcnts
C00234 00039 PROGRAM mathruns, psqrt
C00236 ENDMK
C⊗;
(*$E+,S1200,T-
PASCAL RUNTIME PROGRAM LIBRARY (ARMANDO RODRIGUEZ, SEPT-78)
DERIVED FROM (KISICKI,24-AUG-76)
DICTIONARY:
PAGE1 : DICTIONARY
PAGE2 : CCL HIGHLY MODIFIED VERSION
PAGE3 : DDT
PAGE4 : STATUS
PAGE5 : READ HIGHLY MODIFIED VERSION
PAGE6 : WRITE
PAGE7 : TIMING FOR PASSGO-GENERATED PROGRAMS.
PAGE8 : STRINGS NON-STANDARD 'STRING' PACKAGE.
PAGE9 : DUMPER FOR STATMENT COUNTS (/PROFILE SWITCH)
PAGE10 : MATHRUN TO GIVE ERRORS ON CALLS TO FTN ROUTINES.
note: compiling this source with the switch (or compile option) VERSION:
1: For everybody's use.
3: Local for PASCAL and PASSGO at Stanford Artificial Intelligence Lab.
*)
PROGRAM ccl, option, getoption, getfilename, askfilename, startfile, getparameter, getnextcall, reenter;
(******************************************************************************************
*
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG 13
* GERMANY
* 1976
*
*
* PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
*
* DECSYSTEM-10 CONCISE COMMAND LANGUAGE INTERFACE
*
* PASCAL RUNTIME-SUPPORTS: GETPARAMETER
*
* PRE-DECLARED FUNCTIONS: OPTION
*
* PRE-DECLARED PROCEDURES: GETOPTION,
* GETFILENAME
*
* MODIFIED 1-APR-1978 BY ARMANDO R. RODRIGUEZ, STANFORD UNIVERSITY
* + SWITCHES CAN TAKE NEGATIVE AND ALPHABETIC VALUES.
* + GETPARAMETER WAS BROKEN INTO ASKFILENAME AND STARTFILE
* TO ALLOW THEIR USE BY USER PROGRAMS.
*
* MODIFIED 13-JUL-1978 BY ARMANDO R. RODRIGUEZ, STANFORD UNIVERSITY
* + TAKE IN A SECOND LINE THE NAME OF A PROGRAM TO BE CALLED NEXT.
*
* MODIFIED 18-AUG-1978 BY ARMANDO R. RODRIGUEZ, STANFORD UNIVERSITY
* + ADD THE PROCEDURE REENTER, TO RESET WHAT IS SET IN THE
* INITPROCEDURE, TO ALLOW FOR RESTARTABLE PASCAL PROGRAMS.
*
* DEFINITIONS:
*
* <FILE SPECIFICATION> ::= <EMPTY> OR <FILENAME> OR
* <DEVICE>:<FILENAME>.<EXTENSION>[<PROJECT>,<PROGRAMMER>]<<PROTECTION>>
* (<SWITCH>/.../<SWITCH>)
* /<SWITCH>.../<SWITCH>
*
* <PROGRAMNAME>, <DEVICE>, <FILENAME>, <EXTENSION> ::= <IDENTIFIER>
* <PROJECT>, <PROGRAMMER>, <PROTECTION> ::= <UNSIGNED OCTAL NUMBER>
* <SWITCH> ::= <IDENTIFIER> OR <IDENTIFIER>:<VALUE>
* <VALUE> ::= <DECIMAL NUMBER> OR <LETTER>
*
****************************************************************************************)
TYPE
anyfile = FILE OF integer;
pack9 = PACKED ARRAY[1..9] OF char;
pack7 = PACKED ARRAY[1..7] OF char;
pack6 = PACKED ARRAY[1..6] OF char;
pack5 = PACKED ARRAY[1..5] OF char;
pack3 = PACKED ARRAY[1..3] OF char;
source_form = (tempfile,teletypeoutput,teletypeinput,teletype);
delimiter = (blank,lparent,rparent,comma,point,slash,less,equal,greater,rbrack,lbrack,colon,exclamation,unknown);
swp = ↑switch_descriptor;
switch_descriptor = PACKED RECORD
name: alfa;
left, right: swp;
value: integer
END;
VAR
callcnt, prot_old, ufd_old: integer;
programname: alfa;
tmp_filename, file_old: pack9;
source: source_form;
fromtmpfile,
end_of_filename, defaulted, error, usercall: boolean;
breakchar,
lastch: char;
device_old: pack6;
next_name,
filename: pack9;
next_device,
device: pack6;
current_switch, new_switch, switch_tree: swp;
delimiter1: ARRAY[' '..'/'] OF delimiter;
delimiter2: ARRAY[':'..'>'] OF delimiter;
delimiter3: ARRAY['['..']'] OF delimiter;
INITPROCEDURE;
BEGIN
source := tempfile; callcnt := 0; usercall := true; error := false;
defaulted := true; lastch := ' ';
tmp_filename := ' TMP';
next_name := ' ';
next_device := ' ';
switch_tree := NIL; current_switch := NIL;
delimiter1[' '] := blank; delimiter1['!'] := exclamation;
delimiter1['('] := lparent; delimiter1[')'] := rparent;
delimiter1[','] := comma; delimiter1['.'] := point;
delimiter1['/'] := slash;
delimiter2[':'] := colon; delimiter2['<'] := less;
delimiter2['='] := equal; delimiter2['>'] := greater;
delimiter3['['] := lbrack; delimiter3[']'] := rbrack;
END;
PROCEDURE reenter; (* ADDED TO ALLOW FOR RESTART OF PASCAL PROGRAMS*)
BEGIN (* REENTER *)
source := tempfile; callcnt := 0; usercall := true; error := false;
defaulted := true; lastch := ' ';
tmp_filename := ' TMP';
next_name := ' ';
next_device := ' ';
switch_tree := NIL; current_switch := NIL;
END (* REENTER *);
(** insert ENTER_SWITCH **)
PROCEDURE insert(fname: alfa; fvalue: integer);
PROCEDURE enter_switch(ftree: swp);
BEGIN
WITH ftree↑ DO
IF new_switch↑.name <> name THEN
IF new_switch↑.name < name THEN
IF left = NIL THEN left := new_switch
ELSE enter_switch(left)
ELSE
IF right = NIL THEN right := new_switch
ELSE enter_switch(right)
END (* ENTER_SWITCH *);
BEGIN (* insert *)
new(new_switch);
WITH new_switch↑ DO
BEGIN
name := fname; value := fvalue;
left := NIL ; right := NIL
END;
IF switch_tree = NIL THEN switch_tree := new_switch
ELSE enter_switch(switch_tree)
END (* insert *);
(** GETFILENAME RE_INITIALIZE INITIALIZE READCHAR READOCTAL READDECIMAL SETSTATUS READSWITCH OPERAND NEXTCH ASSIGNFILENAMEOREXTENSION **)
(**********************************************************************
*
* PROCEDURE GETFILENAME
*
* - READ DECSYSTEM-10 <FILE SPECIFICATION> FROM
* "SOURCEFILE".
*
* GETFILENAME IS A PRE-DECLARED PROCEDURE
* AND AVAILABLE TO EVERY PASCAL USER.
*
**********************************************************************)
PROCEDURE getfilename(VAR sourcefile: text;
VAR filename: pack9;
VAR protection,ufd: integer;
VAR device: pack6;
filevariable: alfa);
VAR
buffer: alfa;
i, j, k, imax, ocval, sign, source_prot, source_ppn: integer;
source_fil: PACKED ARRAY[1..9] OF char;
source_dev: PACKED ARRAY[1..6] OF char;
ch,status: char;
new_status: boolean;
PROCEDURE re_initialize;
BEGIN
i := 0; buffer := ' '; ocval := 0; sign :=1;
new_status := false;
END (* RE_INITIALIZE *);
PROCEDURE initialize;
BEGIN
filename := ' '; device := 'DSK '; status := ' '; imax := 6;
ch := ' '; ufd := 0; protection := 0; error := false; end_of_filename := false;
re_initialize; defaulted := true
END (* INITIALIZE *);
FUNCTION picture(fch: char): delimiter;
BEGIN
IF fch IN [' ','!','(',')',',','.','/',':','<','=','>','[',']'] THEN
IF fch <= '/' THEN picture := delimiter1[fch]
ELSE
IF fch <= '>' THEN picture := delimiter2[fch]
ELSE picture := delimiter3[fch]
ELSE picture := unknown;
END (* PICTURE *);
PROCEDURE readchar;
BEGIN
i := i + 1;
IF i > imax THEN error := true
ELSE buffer[i] := ch
END (*READCHAR*) ;
PROCEDURE readoctal;
BEGIN
IF ch IN ['0'..'7'] THEN
BEGIN
ocval := ocval * 10B + ord(ch) - ord('0')
END
ELSE error := true
END (*READOCTAL*) ;
%34
procedure readsixbit;
begin
if ch in [' '..'_'] then
begin
ocval := ocval * 100B + (ord(ch) - ord(' '));
end
else
error := true;
end (*readsixbit*);
\
PROCEDURE readdecimal;
BEGIN
IF ch IN ['0'..'9'] THEN
BEGIN
ocval := ocval * 10 + ord(ch) - ord('0')
END
ELSE
IF ocval = 0 THEN
IF ch IN ['A'..'Z'] THEN
ocval:=ord(ch)
ELSE
IF ch = '-' THEN
sign:=-1
ELSE
error := true
ELSE
error := true;
END (*READDECIMAL*) ;
PROCEDURE setstatus;
BEGIN
IF ch <> ' ' THEN
BEGIN
CASE picture(ch) OF
colon :
error := status <> ' ';
point :
error := NOT (status IN [' ',':']);
lbrack :
error := NOT (status IN [' ',':','.']);
less :
error := NOT (status IN [' ',':','.',']']);
comma :
error := status <> '[';
rbrack :
error := status <> ',';
greater :
error := status <> '<';
slash :
error := NOT (status IN [' ',':','.',']','>',')']);
lparent :
error := NOT (status IN [' ',':','.',']','>']);
rparent :
error := status <> '(';
OTHERS :
error := true
END;
IF NOT error THEN
BEGIN
new_status := true; status := ch
END
END
END (*SETSTATUS*) ;
PROCEDURE readswitch;
VAR
read_value, end_of_switch: boolean;
BEGIN
IF NOT eoln(sourcefile) THEN
BEGIN
REPEAT
imax := alfalength;
re_initialize;
read_value := false;
end_of_switch := false;
LOOP
IF eoln(sourcefile) THEN
BEGIN
end_of_switch := true; ch := ' '
END
ELSE
begin
read(sourcefile,ch);
%34 if ch = '_' then
ch := '=';
\
end;
lastch := ch
EXIT IF NOT (ch IN ['0'..'9',':','A'..'Z',' ','-']) OR end_of_switch;
IF ch <> ' ' THEN
IF read_value THEN readdecimal
ELSE
IF ch = ':' THEN read_value := true
ELSE readchar
END;
IF i > 0 THEN insert(buffer,ocval*sign)
UNTIL NOT (ch IN ['/',',']) OR ((ch = ',') AND (status <> '(')) OR end_of_switch;
IF ch IN [',','=']THEN
BEGIN
end_of_filename := true; ch := ' '
END;
setstatus
END
END (* READSWITCH *);
PROCEDURE operand;
PROCEDURE nextch;
BEGIN
IF eoln(sourcefile) THEN
%34 if status = ',' then
ch := ']'
else
\
BEGIN
end_of_filename := true;
ch := ' ';
END
ELSE
begin
read(sourcefile,ch);
%34 if ch = '_' then
ch := '=';
\
end;
lastch := ch;
IF end_of_filename OR ((ch=',') AND (status<>'[')) OR (ch='=') THEN
BEGIN
end_of_filename := true;
CASE picture(status) OF
blank:
ch := '.';
colon:
ch := '.';
point:
ch := '[';
rparent,
slash,
greater,
rbrack:
BEGIN
ch := ' '; status := ' '
END;
OTHERS:
BEGIN
error := true; ch := ' '
END
END
END
END (*NEXTCH*) ;
BEGIN
(*OPERAND*)
REPEAT
nextch;
IF ch IN ['A'..'Z','0'..'9'] THEN
IF status IN ['[',',','<'] THEN
%34 if status <> '<' then
readsixbit
else
\
readoctal
ELSE readchar
ELSE setstatus
UNTIL new_status OR error OR end_of_filename
END (*OPERAND*) ;
PROCEDURE assignfilenameorextension;
BEGIN (*ASSIGNFILENAMEOREXTENSION*)
IF i > 0 THEN
IF (filename[1] = ' ') OR ((filename[7] = ' ') AND (imax = 3)) THEN
BEGIN
IF imax = 3 THEN k := 6
ELSE k := 0;
FOR j := 1 TO imax DO filename[k+j] := buffer[j];
END
END (*ASSIGNFILENAMEOREXTENSION*);
(***********************************************************************
*
* PROCEDURE GETNEXTPROCESSOR
*
* _ READ THE SECOND LINE OF A TOPS-20 CCL FILE.
*
* <FILENAME>!
*
* WHERE FILENAME IS A NAME OF A PROGRAN TO BE RUN AFTER PASCAL
*
***********************************************************************)
PROCEDURE getnextprocessor;
VAR
token: pack7;
brkchar: char;
PROCEDURE gettoken(VAR token: pack7;
VAR brkch: char);
BEGIN
i := 1; token := ' ';
read(sourcefile,ch);
WHILE NOT (ch IN [':','.','!']) AND NOT eoln(sourcefile) AND (i <= 7) DO
BEGIN
token[i] := ch;
read(sourcefile,ch); i := i + 1;
END;
IF ch IN [':','.','!'] THEN
brkch := ch
ELSE
brkch := ' ';
END (* GETTOKEN *);
BEGIN (* GETNEXTPROCESSOR *)
gettoken(token, brkchar);
IF brkchar = ':' THEN
BEGIN
FOR i:=1 TO 6 DO
next_device[i] := token[i];
gettoken (token, brkchar);
END
ELSE
next_device := 'DSK ';
IF brkchar IN ['.', '!'] THEN
BEGIN
FOR i:=1 TO 6 DO
next_name[i] := token[i];
IF brkchar = '.' THEN (* SKIP EXTENSION *)
gettoken(token, brkchar);
IF brkchar <> '!' (* LINE NOT TERMINATING CORRECTLY *) THEN
next_name := ' ';
END
ELSE
next_name := ' ';
END (* GETNEXTPROCESSOR *);
BEGIN (*GETFILENAME*)
LOOP
IF usercall THEN
BEGIN
getstatus(sourcefile, source_fil, source_prot, source_ppn, source_dev);
IF source_dev = 'TTY ' THEN
BEGIN
write(tty,cr,lf,filevariable,'= ');
break(tty);
readln(sourcefile)
END
END;
initialize;
IF NOT eof(sourcefile) THEN
IF NOT eoln(sourcefile) THEN
REPEAT
operand;
IF NOT error THEN
BEGIN
CASE picture(status) OF
colon:
IF i > 0 THEN BEGIN
device := ' ' ;
FOR j := 1 TO i DO device[j] := buffer[j];
END ;
point:
BEGIN
assignfilenameorextension; imax := 3
END;
less,
lbrack:
assignfilenameorextension;
lparent,
slash:
BEGIN
assignfilenameorextension; readswitch
END;
comma :
%34 if ocval >= 400000B then
ufd := (ocval - 400000B) * 1000000B + 400000000000B
else
\
ufd := ocval * 1000000B;
rbrack :
ufd := ufd + ocval;
greater :
protection := ocval
END;
re_initialize; defaulted := false
END
UNTIL error OR end_of_filename;
defaulted := (filename[1] = ' ') AND (device = 'DSK ');
IF NOT defaulted THEN
IF NOT error AND eoln(sourcefile) AND (pred(source) = tempfile) AND NOT eof(sourcefile) THEN
BEGIN
readln(sourcefile);
status := ' ';
ch := ' ';
IF NOT eoln (sourcefile) THEN
begin
lastch := ' ';
getnextprocessor;
end;
END;
EXIT IF NOT (error AND usercall);
writeln(tty,'%? SYNTAX ERROR: REENTER'); break(tty);
END;
usercall := true;
END (*GETFILENAME*);
(** GETPARAMETER ASKFILENAME STARTFILE INITIALIZE **)
(**********************************************************************
*
* PROCEDURE GETPARAMETER
*
* - READ A DECSYSTEM-10 <FILE SPECIFICATION> FROM EITHER
*
* * A TEMPCORE-FILE NAMED <1ST 3 CHARS. OF PROGRAMNAME>.TMP,
* CREATED BY DECSYSTEM-10 COMPIL-CLASS COMMANDS OR USER, OR
*
* * TTY
*
* ALL FILES HAVE TO BE "TEXT"-FILES.
*
* TEMPCORE-FILES CAN BE ACCESSED AND CREATED AUTOMATICALLY
* BY PASCAL PROGRAMS IF THE FILENAME IS SPECIFIED AS
* 'XXX TMP' AND DEVICE IS 'DSK ', WHERE XXX ARE
* THE 1ST 3 CHARACTERS OF THE <PROGRAMNAME>. IF THE TEMPCORE-FILE
* CANNOT BE FOUND/CREATED THE DISK-FILE 'NNNXXXTMP' IS
* SEARCHED/CREATED, WHERE NNN IS THE JOB-NUMBER.
*
* - GETPARAMETER IS PART OF THE PASREL RUNTIME-SUPPORT.
* A CALL OF GETPARAMETER IS GENERATED BY THE PASREL COMPILER
* FOR EACH PARAMETER SPECIFIED IN THE <PROGRAM HEADING>.
*
* ASKFILENAME AND STARTFILE CONTAIN WHAT ORIGINALLY WAS GETPARAMETER,
* BROKEN IN TWO PARTS SO THAT YOU CAN SUPRESS OPPENING OF
* THE FILE (STARTFILE) IF DESIRED SO. THEY ARE BOTH PRE-DECLARED
* PROCEDURES, AND AVAILABLE TO EVERY PASCAL USER.
* (CHANGE MADE AT LOTS, STANFORD UNIVERSITY, BY ARMANDO
* RODRIGUEZ, 1-APR-1978).
*
* THE INPUT FORMAT IS FOR
*
* * TEMPCORE-FILES:
*
* <FILE SPECIFICATION>,...,<FILE SPECIFICATION>/<SWITCH>.../<SWITCH><CR><LF>
* <DEVICE>:<FILENAME>!<CR><LF>
*
* THE SECOND LINE (USED BY COMPIL-CLASS COMMANDS) IS OPTIONAL
*
* * TTY:
*
* <FILE SPECIFICATION><CR><LF>
*
***********************************************************************)
PROCEDURE initialize;
VAR
i: integer;
BEGIN
IF source <> teletype THEN
BEGIN
CASE source OF
tempfile:
BEGIN
FOR i := 1 TO 3 DO tmp_filename[i] := programname[i];
reset(tty,tmp_filename,0,0,'DSK ')
END;
teletypeoutput:
rewrite(tty,'TTYOUTPUT');
teletypeinput:
reset(tty,'TTY ',0,0,'TTY ')
END;
source := succ(source);
IF eof(tty) AND NOT (source IN [teletypeinput,teletype]) THEN initialize;
END
END (* INITIALIZE *);
PROCEDURE askfilename(VAR filename: pack9;
VAR protection,ufd: integer;
VAR device: pack6;
fileident,progname: alfa;
inputfile: boolean;
VAR fromtmpfile: boolean;
var breakchar: char);
BEGIN (*ASKFILENAME*)
programname:=progname;
IF callcnt = 0 THEN
initialize;
callcnt := callcnt + 1;
LOOP
IF source IN [teletype,teletypeinput] THEN
BEGIN
write(tty,fileident,'= ');break(tty);
IF source = teletypeinput THEN initialize
ELSE readln(tty)
END;
usercall := false;
getfilename(tty,filename,protection,ufd,device,' ');
IF device = 'LPT ' THEN insert('LPT ',0) ;
error := (inputfile AND NOT defaulted AND (device = 'LPT ')) OR error;
EXIT IF NOT error;
IF source <> teletype THEN
BEGIN
source := teletypeoutput; initialize
END;
writeln(tty,'%? SYNTAX ERROR: REENTER');
break(tty);
END;
fromtmpfile := pred(source) = tempfile;
breakchar := lastch;
enD (*ASKFILENAME*);
PROCEDURE startfile(VAR currentfile: anyfile;
VAR filename: pack9;
VAR protection,ufd: integer;
VAR device: pack6;
inputfile: boolean;
fileident: alfa;
defaultext: pack3);
VAR
i: integer;
extdefaulted: boolean;
tempfile: pack9;
BEGIN (*STARTFILE*)
IF usercall = true THEN
BEGIN
defaulted:=(filename=' ') AND (device = 'DSK ');
source:=teletype;
FOR i:=1 TO 9 DO
file_old[i]:=fileident[i];
prot_old:=0;
ufd_old:=0;
device_old:='DSK ';
extdefaulted := (filename[7] = ' ') AND (defaultext[1] <> ' ');
END
ELSE
extdefaulted := false;
error:=false;
LOOP
IF NOT error THEN
IF defaulted THEN
IF inputfile THEN
BEGIN
IF device_old = 'TTY ' THEN
BEGIN
write(tty,'TO CONTINUE, HIT THE RETURN KEY *');
break(tty);
END;
reset(currentfile,file_old,prot_old,ufd_old,device_old)
END
ELSE
rewrite(currentfile,file_old,prot_old,ufd_old,device_old)
ELSE
BEGIN
IF extdefaulted THEN
BEGIN
tempfile := filename;
FOR i := 1 TO 3 DO
filename[i + 6] := defaultext[i];
END;
IF inputfile THEN
BEGIN
IF device = 'TTY ' THEN
BEGIN
write(tty,'TO CONTINUE, HIT THE RETURN KEY *');
break(tty);
END;
reset(currentfile,filename,protection,ufd,device);
IF extdefaulted AND eof(currentfile) THEN
reset(currentfile,tempfile,protection,ufd,device);
END
ELSE
rewrite(currentfile,filename,protection,ufd,device);
END;
EXIT IF ( (NOT eof(currentfile) AND inputfile) OR (eof(currentfile) AND NOT inputfile) ) AND NOT error;
IF source <> teletype THEN
BEGIN
source := teletypeoutput; initialize
END;
IF error THEN writeln(tty,'%? SYNTAX ERROR: REENTER')
ELSE
BEGIN
write(tty,'%? NO ACCESS TO ');
IF filename = ' ' THEN write(tty,fileident:6,'.',fileident[7],fileident[8],fileident[9])
ELSE
BEGIN
write(tty,filename:6,'.',filename[7],filename[8],filename[9]);
IF extdefaulted THEN
write(tty,' NOR TO ',tempfile:6,'. ');
END;
writeln(tty,' OR NOT FOUND: REENTER')
END;
break(tty);
IF source IN [teletype,teletypeinput] THEN
BEGIN
write(tty,fileident,'= ');break(tty);
IF source = teletypeinput THEN initialize
ELSE readln(tty)
END;
usercall := false;
getfilename(tty,filename,protection,ufd,device,' ');
IF device = 'LPT ' THEN insert('LPT ',0) ;
error := (inputfile AND NOT defaulted AND (device = 'LPT ')) OR error;
END
END (*STARTFILE*);
PROCEDURE getparameter(VAR currentfile: anyfile;
VAR fileident,programname:alfa;
inputfile:boolean);
VAR
protection, ufd: integer;
BEGIN (*GETPARAMETER*)
getstatus(currentfile,file_old,prot_old,ufd_old,device_old);
askfilename(filename,protection,ufd,device,fileident,programname,inputfile, fromtmpfile,breakchar);
usercall:=false;
startfile(currentfile,filename,protection,ufd,device,inputfile,fileident,' ');
END (*GETPARAMETER*) ;
(** OPTION FIND_SWITCH GETOPTION PICTURE **)
(**********************************************************************
*
* FUNCTION OPTION
*
* - TEST IF <SWITCH> "SWITCHNAME" HAS BEEN
* SPECIFIED IN THE DECSYSTEM-10 COMMAND-STRING
* INTERPRETED BY PREVIOUS GETPARAMETER-/GETFILENAME-CALLS.
*
* OPTION IS A PRE-DECLARED FUNCTION AND AVAILABLE TO EVERY
* PASCAL USER.
*
**********************************************************************)
FUNCTION option(switchname: alfa): boolean;
FUNCTION find_switch( ftree: swp): boolean;
BEGIN
IF ftree <> NIL THEN
WITH ftree↑ DO
IF switchname = name THEN
BEGIN
find_switch := true; current_switch := ftree
END
ELSE
IF switchname < name THEN
find_switch := find_switch(left)
ELSE
find_switch := find_switch(right)
ELSE find_switch := false
END (* FIND_SWITCH *);
BEGIN (*OPTION*)
IF switch_tree = NIL THEN
option := false
ELSE
option := find_switch(switch_tree)
END (*OPTION*);
(**********************************************************************
*
* PROCEDURE GETOPTION
*
* - ASSIGN <VALUE> OF "SWITCHNAME" TO "SWITCHVALUE".
*
* GETOPTION IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO EVERY
* PASCAL USER.
*
**********************************************************************)
PROCEDURE getoption(switchname: alfa; VAR switchvalue: integer);
BEGIN
IF option(switchname) THEN
WITH current_switch↑ DO
switchvalue := value
ELSE
switchvalue := 0
;
END (* GETOPTION *);
(**********************************************************************
*
* PROCEDURE GETNEXTCALL
*
* - ASSIGN <VALUE> OF "NEXT_NAME" TO "FILENAME" AND
* <VALUE> OF "NEXT_DEVICE" TO "DEVICE", THAT IS,
* TRANSMIT THE DATA OF THE NEXT PROGRAM TO BE CALLED.
*
* GETNEXTCALL IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO EVERY
* PASCAL USER.
*
**********************************************************************)
PROCEDURE getnextcall (VAR filename: pack9;
VAR device: pack6);
BEGIN (*GETNEXTCALL*)
filename := next_name;
device := next_device;
END (*GETNEXTCALL*);
BEGIN
END.
PROGRAM ddt, debug;
(************************************************************
* *
* *
* PASCAL-DDT PROGRAM *
* ****************** *
* *
* *
* AUTHOR: PETER PUTFARKEN *
* *
* POST - MORTEM - DUMP BY *
* B. NEBEL AND B. PRETSCHNER (APR 76) *
* *
* INSTITUT FUER INFORMATIK *
* SCHLUETERSTRASSE 70 *
* D-2000 HAMBURG 13 *
* GERMANY *
* *
* *
***********************************************************)
CONST
version = 'DEBUG(VERSION FROM 25-AUG-76)';
stopmax = 20;
buffmax = 120;
bitmax = 36;
basemax = 71;
strglgth = 120;
offset = 40B;
maxtabs = 4;
TYPE
acrange = 0..15; bit = 0..1;
bitrange = 0..bitmax;
addrrange = 0..777777B;
lineelem = PACKED RECORD
CASE integer OF
1: (code:0..677B; ac:acrange; ib:bit; inxr:acrange; adp:↑lineelem);
2: (constant1: integer;
db2: addrrange; absline: addrrange)
END;
pageelem = PACKED RECORD
instr: 0..677B; ac: acrange; dummybit: bit; inxreg: acrange; pagptr: ↑pageelem;
lastline: addrrange; laststop: ↑lineelem
END;
stringtyp = PACKED ARRAY [1:strglgth] OF char;
cstclass = (int,reel,pset,strd,strg);
sixbit=PACKED ARRAY[1..6] OF 0..77B;
csp = ↑constnt;
constnt = RECORD
selfcsp: csp; nocode: boolean;
CASE cclass: cstclass OF
int : (intval: integer; intval1: integer)
END;
valu = RECORD
CASE integer OF
1: (ival: integer);
2: (rval: real);
3: (bval: boolean);
4: (valp: csp)
END;
bits5 = 0..37B; bits6 = 0..77B; bits7 = 0..177B;
bits17 = 0..377777B; bits18 = 0..777777B;
structform = (scalar,subrange,pointer,power,arrays,records,files,tagfwithid,tagfwithoutid,variant);
formset=SET OF structform;
declkind = (standard,declared);
stp = ↑structure; ctp = ↑identifier;
structure = PACKED RECORD
selfstp: stp; size: addrrange;
nocode: boolean;
bitsize: bitrange;
CASE form: structform OF
scalar: (CASE scalkind: declkind OF
declared: (db0:bits6; fconst: ctp));
subrange: (db1:bits7; rangetype: stp; minv,maxv: valu);
pointer: (db2:bits7; eltype: stp);
power: (db3:bits7; elset: stp);
arrays: (arraypf: boolean; db4:bits6; arraybpaddr: addrrange;
aeltype,inxtype: stp);
records: (recordpf:boolean; db5:bits6;
fstfld: ctp; recvar: stp);
files: (db6: bits6; filepf: boolean; filtype: stp);
tagfwithid,
tagfwithoutid: (db7:bits7; fstvar: stp;
CASE boolean OF
true : (tagfieldp: ctp);
false: (tagfieldtype: stp));
variant: (db9: bits7; nxtvar,subvar: stp; firstfield: ctp; varval: valu)
END;
(* ALFA = PACKED ARRAY[1..ALFALENG] OF CHAR; *)
levrange = 0..10;
idclass = (types,konst,vars,field,proc,func,labels);
idkind = (actual,formal);
packkind = (notpack,packk,hwordr,hwordl);
bpointer = PACKED RECORD
sbits,pbits: bitrange;
ibit,dummybit: bit;
ireg: acrange;
reladdr: addrrange
END;
identifier = PACKED RECORD
name: alfa; llink, rlink: ctp;
idtype: stp; next: ctp;
selfctp: ctp; nocode: boolean;
CASE klass: idclass OF
konst: (values: valu);
vars: (vkind: idkind; vlev: levrange;
channel: acrange; vdummy1: 0..37B; vdummy2:0..777777B; vaddr: addrrange);
field: (CASE packf: packkind OF
notpack,
hwordl,
hwordr: (fdummy: 0..7777B; fldaddr: addrrange);
packk: (pdummy: 0..7777B; fldbyte: bpointer));
proc,
func: (CASE pfdeckind: declkind OF
standard: (key: 1..44);
declared: (pflev: levrange; pfaddr: addrrange))
END;
symbol= (stopsy, tracesy, endsy, notsy, eolsy, ident, intconst, stringconst,
charconst, realconst, lbrack, rbrack, comma, period, arrow, plus, minus, mul,
slashsy, becomes, eqsy, lparent, rparent, othersy, stackdumpsy, heapdumpsy);
ascii_mnemonics = (nul,soh,stx,etx,eot,enq,ack,bel,
bs,ht,lf,vt,ff,cr,so,si,
dle,dc1,dc2,dc3,dc4,nak,syn,etb,
can,em,sub,esc,fs,gs,rs,us,del);
acr = ↑ aktivierungsrecord;
aktivierungsrecord = ARRAY [0..0] OF integer;
attrkind = (cst,varbl,expr);
attr = RECORD
typtr: stp;
CASE kind: attrkind OF
cst,
expr: (cval: valu);
varbl:(packfg: boolean;
gaddr: addrrange;
gbitcount: bitrange;
maxaddr:addrrange)
END;
leftorright=(left,right);
debugentry = RECORD
lastpageelem: pageelem;
globalidtree: ctp;
standardidtree: ctp;
intptr: stp;
realptr: stp;
boolptr: stp;
charptr: stp
END;
statuskind = (initk, stopk, ddtk, runtmerrk, haltk);
debugstatus = PACKED RECORD
dd: 0:77777B;
kind: statuskind;
returnaddr: addrrange
END;
dynentry = PACKED RECORD
dumm1: bits18; (* LH 140B *)
registrs: acr; (* RH 140B *)
stoppy: integer; (* 141B *)
dumm2: bits18; (* LH 142B *)
entryptr: ↑debugentry; (* RH 142B *)
dumm3: bits17;
interactive: boolean; (* LH 143B *)
stackbottom: acr; (* RH 143B *)
status: debugstatus; (* 144B *)
time_limit: integer; (* 145B USED ONLY BY BATCH JOBS *)
pushj_indeb: integer; (* 146B *)
dummi146: addrrange; (* 147B LH *)
name_pnt_pnt: acr (* 147B RH POINTER OF POINTER OF PROGRAM-NAME *)
END;
VAR
dump, tabs: boolean;
tabulator: ARRAY[boolean,1..maxtabs] OF integer;
file_name: PACKED ARRAY[1..9] OF char;
ascii_change: RECORD
CASE integer OF
1: (ival: integer);
2: (mnemo: ascii_mnemonics)
END;
day, day_time: alfa;
device:PACKED ARRAY[1..6] OF char;
ch: char;
id: alfa;
val: valu;
string: ↑stringtyp;
stringptr, stringindex: stp;
lgth: integer;
chcnt, leftspace: integer;
sy: symbol;
buffer: PACKED ARRAY[1:buffmax] OF char;
bufflng: 0:buffmax;
gpage: integer; (*CURRENT PAGENUMBER*)
stoptable: ARRAY[1..stopmax] OF PACKED RECORD
thisline: integer;
page: addrrange;
thisaddr: ↑lineelem;
originalcont: integer
END;
stopnr: 0..stopmax;
entry1: debugentry;
entry2: dynentry;
pointercv: PACKED RECORD
CASE integer OF
0:(addr: addrrange);
1:(entptr2: ↑dynentry);
2:(stringptr: ↑stringtyp);
3:(ctptr: ctp);
4:(alfapnt:↑alfa)
END;
heapcv:PACKED RECORD
CASE boolean OF
true: (cival:integer);
false: (cidtype:stp;
cacr:acr)
END;
merkbasis,basis, accus, nullptr: acr;
bytecv: PACKED RECORD
CASE boolean OF
false: (bits: PACKED ARRAY[1..bitmax] OF bit );
true : (intconst: integer)
END;
laddr: addrrange;
digits, lettersdigitsorleftarrow: SET OF char;
nl: boolean;
gattr: attr;
(******************************************************************************************************)
INITPROCEDURE;
BEGIN
digits :=['0'..'9'];
lettersdigitsorleftarrow:=['A'..'Z','0'..'9', '_'];
string := NIL;
tabulator[true,1]:=35;
tabulator[true,2]:=65;
tabulator[true,3]:=95;
tabulator[true,4]:=377777777777B;
tabulator[false,1]:=0;
tabulator[false,2]:=0;
tabulator[false,3]:=35;
tabulator[false,4]:=377777777777B;
tabs:=false;
dump:=false;
END;
(** DEBUG [ SYSTEM_ERROR ERROR NEWLINE LENGTH **)
PROCEDURE debug;
PROCEDURE system_error( kind : integer );
BEGIN
writeln(tty);
writeln(tty,'%? DEBUG-SYSTEM ERROR: ',kind:2);
halt; (* JUMP TO "HALT.".
THERE WILL BE DECDECTED THAT
DEBUG IS LOADED. THEREFORE, JUMP TO
"ERRDB." AND EXIT *)
END;
PROCEDURE error;
BEGIN
write(tty, '$', '↑ ':chcnt+1 );
gattr.typtr := NIL
END (*ERROR*);
PROCEDURE newline;
VAR
i:integer;
BEGIN
i:=1;
IF tabs THEN
WHILE (tabulator[dump,i] <= chcnt) DO
i:=i+1;
IF (i = maxtabs) OR NOT tabs THEN
BEGIN
writeln(tty);
write(tty,'$ ',' ':leftspace);
chcnt:=leftspace;
END
ELSE
BEGIN
write(tty,' ':tabulator[dump,i]-chcnt);
chcnt:=tabulator[dump,i];
END (* ELSE *)
END (* NEWLINE *);
FUNCTION length(fval: integer): integer;
VAR
e, h: integer;
BEGIN
IF fval < 0 THEN
BEGIN
e := 1; fval := -fval
END
ELSE e := 0;
h := 1;
IF fval >= 10000000000 (* 10**10 *) THEN e := e + 11
ELSE
REPEAT
e := e + 1; h := h * 10
UNTIL (fval < h) ;
length := e
END (*LENGTH*);
(** INSYMBOL NEXTCH **)
PROCEDURE insymbol;
CONST
max10 = 3817748707;
maxexp = 35;
VAR
ival,scale,exp,i: integer;
rval,r,fac: real;
stringtoolong, sign: boolean;
PROCEDURE nextch;
BEGIN
IF eoln(tty) THEN ch:=' '
ELSE read(tty,ch);
chcnt := chcnt + 1
END (*NEXTCH*);
BEGIN
WHILE NOT eoln(tty) AND (ch=' ') DO nextch;
CASE ch OF
' ':
sy := eolsy;
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y',
'Z':
BEGIN
id := ' '; i := 0;
REPEAT
IF i < alfalength THEN
BEGIN
i := i + 1;
id[i] := ch
END;
nextch
UNTIL NOT ( ch IN lettersdigitsorleftarrow );
sy := ident;
IF id='NOT ' THEN sy:=notsy;
IF id='STOP ' THEN sy:=stopsy;
IF id='TRACE ' THEN sy:=tracesy;
IF id='END ' THEN sy:=endsy;
IF id='STACKDUMP ' THEN sy:=stackdumpsy;
IF id='HEAPDUMP ' THEN sy:=heapdumpsy;
IF sy IN [stopsy,tracesy,stackdumpsy,heapdumpsy] THEN
(* LOOK AHEAD, WHETHER ARGUMENT OR EOL FOLLOWS *)
BEGIN
WHILE NOT eoln(tty) AND (ch=' ') DO nextch;
IF NOT (ch IN ['0'..'9','A'..'Z',' '] ) THEN sy:= ident
END
END;
'0','1','2','3','4','5','6','7','8',
'9':
BEGIN
ival := 0; sy := intconst;
REPEAT
IF ival <= max10 THEN ival := 10*ival + ord(ch)-ord('0')
ELSE
BEGIN
error; writeln(tty,'NUMBER TOO LARGE');
ival := 0
END;
nextch
UNTIL NOT (ch IN digits);
scale := 0;
IF ch = '.' THEN
BEGIN
nextch;
IF ch = '.' THEN ch := ':'
ELSE
BEGIN
rval := ival; sy := realconst;
IF NOT (ch IN digits) THEN
BEGIN
error; writeln(tty,'DIGIT MUST FOLLOW')
END
ELSE
REPEAT
rval := 10.0*rval + (ord(ch) - ord('0'));
scale := scale - 1; nextch
UNTIL NOT (ch IN digits)
END
END;
IF ch = 'E' THEN
BEGIN
IF scale = 0 THEN
BEGIN
rval := ival; sy := realconst
END;
nextch;
sign := ch = '-' ;
IF (ch = '+') OR sign THEN nextch;
exp := 0;
IF NOT (ch IN digits) THEN
BEGIN
error; writeln(tty,'DIGIT MUST FOLLOW')
END
ELSE
REPEAT
exp := 10*exp + ord(ch) - ord('0');
nextch
UNTIL NOT (ch IN digits);
IF sign THEN scale := scale - exp
ELSE scale := scale + exp;
IF abs(scale + length(ival) - 1) > maxexp THEN
BEGIN
error; writeln(tty,'EXPONENT TOO LARGE');
scale := 0
END
END;
IF scale <> 0 THEN
BEGIN
r := 1.0; (*NOTE POSSIBLE OVERFLOW OR UNDERFLOW*)
IF scale < 0 THEN
BEGIN
fac := 0.1; scale := -scale
END
ELSE fac := 10.0;
REPEAT
IF odd(scale) THEN r := r*fac;
fac := sqr(fac); scale := scale DIV 2
UNTIL scale = 0;
(*NOW R = 10↑SCALE*)
rval := rval*r
END;
IF sy = intconst THEN val.ival := ival
ELSE val.rval := rval
END;
':':
BEGIN
nextch;
IF ch = '=' THEN
BEGIN
sy := becomes; nextch
END
ELSE sy := othersy
END;
'''':
BEGIN
lgth := 0; stringtoolong := false;
IF string = NIL THEN
BEGIN
new(string); new(stringptr,arrays); new(stringindex,subrange);
WITH stringindex↑ DO
BEGIN
size := 1; bitsize := 7;
rangetype := entry1.intptr; minv.ival := 1
END;
WITH stringptr↑ DO
BEGIN
bitsize := bitmax; aeltype := entry1.charptr;
inxtype := stringindex; arraypf := true
END
END;
REPEAT
REPEAT
nextch;
IF lgth < strglgth THEN
BEGIN
lgth := lgth + 1; string↑[lgth] := ch
END
ELSE stringtoolong := true
UNTIL eoln(tty) OR (ch = '''');
IF stringtoolong THEN
BEGIN
error; writeln(tty,'STRING CONSTANT IS TOO LONG')
END;
IF ch <> '''' THEN
BEGIN
error; writeln(tty,'STRING CONSTANT CONTAINS "<CR><LF>"')
END
ELSE nextch
UNTIL ch <> '''';
lgth := lgth - 1; (*NOW LGTH = NR OF CHARS IN STRING*)
IF lgth = 1 THEN
BEGIN
sy := charconst; val.ival := ord(string↑[1])
END
ELSE
BEGIN
sy := stringconst;
stringindex↑.maxv.ival := lgth;
stringptr↑.size := (lgth + 4) DIV 5
END
END;
'=':
BEGIN
sy := eqsy; nextch
END;
'/':
BEGIN
sy := slashsy; nextch
END;
'[':
BEGIN
sy := lbrack; nextch
END;
']':
BEGIN
sy := rbrack; nextch
END;
'.':
BEGIN
sy := period; nextch
END;
'↑':
BEGIN
sy := arrow; nextch
END;
',':
BEGIN
sy := comma; nextch
END;
'+':
BEGIN
sy := plus; nextch
END;
'*':
BEGIN
sy := mul; nextch
END;
'-':
BEGIN
sy := minus; nextch
END;
'(':
BEGIN
sy := lparent; nextch
END;
')':
BEGIN
sy := rparent; nextch
END;
OTHERS:
sy := othersy
END;
END (*INSYMBOL*);
(** ACRPOINT TESTGLOBALBASIS IDTREE FIRSTBASIS SUCCBASIS SEARCHSECTION SEARCHID **)
FUNCTION acrpoint(fint:integer;lleft:leftorright): acr;
(*CONVERTS INTEGER TO ACR-POINTER*)
VAR
acr_int: PACKED RECORD
CASE boolean OF
false:(lint: integer);
true: (lacr,lacl: acr)
END;
BEGIN
WITH acr_int DO
BEGIN
lint := fint;
IF lleft=left THEN acrpoint := lacl
ELSE acrpoint := lacr
END
END (*ACRPOINT*);
PROCEDURE testglobalbasis;
BEGIN
IF basis = entry2.stackbottom THEN basis := nullptr
END (*TESTGLOBALBASIS*);
FUNCTION idtree: ctp;
(*POINTS TO THE IDTREE OF THE PROCEDURE, TO WHICH BASIS POINTS*)
VAR
i: integer;
lacr: acr;
BEGIN
IF basis = nullptr THEN idtree := entry1.globalidtree
ELSE
BEGIN
lacr := acrpoint ( basis↑[0] - 1, right );
i := lacr↑[0];
REPEAT
i := i - 1;
lacr := acrpoint ( i, right)
UNTIL ord(acrpoint(lacr↑[0],right)) <> 777777B (*HRR BASIS,-1(BASIS)*);
WITH pointercv DO
BEGIN
addr := lacr↑[0];
idtree := ctptr
END
END
END (*IDTREE*);
PROCEDURE firstbasis;
(*GENERATES BASISPOINTER TO 'AKTIVIERUNGSRECORD' OF UNDERBREAKED PROCEDURE*)
BEGIN
basis := acrpoint ( accus↑[0 +16B], right );
testglobalbasis
END (*FIRSTBASIS*);
PROCEDURE succbasis(side: leftorright);
(*GENERATES BASISPOINTER TO 'AKTIVIERUNGSR.'
OF STATIC/DYNAMIC HIGHER PROCEDURE)*)
(*SIDE: RIGHT FOR STATIC LINK
LEFT FOR DYNAMIC LINK*)
VAR
oldbasis:acr;
BEGIN
oldbasis:=basis;
basis := acrpoint( basis↑[0-1], side );
testglobalbasis;
IF ord(oldbasis) <= ord(basis) THEN
BEGIN
basis:=nullptr;
tabs:=false; newline;
write(tty,'ERROR IN PROCEDURE-BACKTRACING'); newline;
END;
END (*SUCCBASIS*);
PROCEDURE searchsection(fcp: ctp; VAR fcp1: ctp);
LABEL
1;
BEGIN
WHILE fcp <> NIL DO WITH fcp↑ DO
BEGIN
IF name = id THEN GOTO 1;
IF name < id THEN fcp := rlink
ELSE fcp := llink
END;
1:
fcp1 := fcp
END (*SEARCHSECTION*);
PROCEDURE searchid(VAR fcp: ctp);
LABEL
1;
VAR
lcp: ctp;
BEGIN
firstbasis;
LOOP
searchsection( idtree, lcp );
IF lcp <> NIL THEN GOTO 1
EXIT IF basis = nullptr;
succbasis ( right(*=STATIC*) )
END;
searchsection( entry1.standardidtree, lcp );
1:
fcp := lcp
END (*SEARCHID*);
(** GETBOUNDS COMPTYPES **)
PROCEDURE getbounds(fsp: stp; VAR fmin,fmax: integer);
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
(*ASSUME (FSP <> NIL) AND (FSP↑.FORM <= SUBRANGE) AND (FSP <> INTPTR)
AND NOT COMPTYPES(REALPTR,FSP)*)
BEGIN
WITH fsp↑ DO
IF form = subrange THEN
BEGIN
fmin := minv.ival; fmax := maxv.ival
END
ELSE
BEGIN
fmin := 0;
IF fsp = entry1.charptr THEN fmax := 177B
ELSE
IF fconst <> NIL THEN fmax := fconst↑.values.ival
ELSE fmax := 0
END
END (*GETBOUNDS*) ;
FUNCTION comptypes(fsp1,fsp2: stp) : boolean;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR
nxt1,nxt2: ctp; comp: boolean; lmin,lmax,i: integer;
BEGIN
IF fsp1 = fsp2 THEN comptypes := true
ELSE
IF (fsp1 <> NIL) AND (fsp2 <> NIL) THEN
IF fsp1↑.form = fsp2↑.form THEN
CASE fsp1↑.form OF
scalar:
comptypes := false;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
subrange:
comptypes := comptypes(fsp1↑.rangetype,fsp2↑.rangetype);
pointer:
comptypes := comptypes(fsp1↑.eltype,fsp2↑.eltype);
power:
comptypes := comptypes(fsp1↑.elset,fsp2↑.elset);
arrays:
BEGIN
getbounds (fsp1↑.inxtype,lmin,lmax);
i := lmax-lmin;
getbounds (fsp2↑.inxtype,lmin,lmax);
comptypes := comptypes(fsp1↑.aeltype,fsp2↑.aeltype)
AND (fsp1↑.arraypf = fsp2↑.arraypf) AND ( i = lmax - lmin )
END;
(*ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
BE COMPATIBLE. MAY GIVE TROUBLE FOR ENT OF STRINGCONSTANTS
-- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
BE THE SAME*)
records:
BEGIN
nxt1 := fsp1↑.fstfld; nxt2 := fsp2↑.fstfld; comp := true;
WHILE (nxt1 <> NIL) AND (nxt2 <> NIL) DO
BEGIN
comp := comptypes(nxt1↑.idtype,nxt2↑.idtype) AND comp;
nxt1 := nxt1↑.next; nxt2 := nxt2↑.next
END;
comptypes := comp AND (nxt1 = NIL) AND (nxt2 = NIL)
AND (fsp1↑.recvar = NIL) AND (fsp2↑.recvar = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IF NO VARIANTS OCCUR*)
files:
comptypes := comptypes(fsp1↑.filtype,fsp2↑.filtype)
END (*CASE*)
ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
IF fsp1↑.form = subrange THEN comptypes := comptypes(fsp1↑.rangetype,fsp2)
ELSE
IF fsp2↑.form = subrange THEN comptypes := comptypes(fsp1,fsp2↑.rangetype)
ELSE comptypes := false
ELSE comptypes := true
END (*COMPTYPES*) ;
(** NEXTBYTE PUTNEXTBYTE **)
FUNCTION nextbyte(fbitsize: integer ): integer;
VAR
lval,j: integer;
BEGIN
WITH gattr DO
IF packfg THEN
BEGIN
lval := 0;
IF fbitsize + gbitcount > bitmax THEN
BEGIN
gaddr := gaddr + 1;
gbitcount := 0
END;
IF fbitsize = bitmax THEN lval := basis↑[gaddr]
ELSE
WITH bytecv DO
BEGIN
intconst := basis↑[gaddr];
FOR j := gbitcount + 1 TO gbitcount + fbitsize DO
lval := lval*2 + bits[j]
END;
gbitcount := gbitcount + fbitsize;
nextbyte := lval
END (*IF PACKFG*)
ELSE
BEGIN
IF gbitcount > 0 THEN system_error(1);
nextbyte := basis↑[gaddr];
gaddr := gaddr + 1; gbitcount := 0
END
END (*NEXTBYTE*);
PROCEDURE putnextbyte( fbitsize, fval: integer );
VAR
j: integer;
BEGIN
WITH gattr, bytecv DO
BEGIN
IF fbitsize + gbitcount > bitmax THEN
BEGIN
gaddr := gaddr + 1; gbitcount := 0
END;
intconst := basis↑[gaddr];
FOR j := gbitcount + fbitsize DOWNTO gbitcount+ 1 DO
BEGIN
bits[j] := ord(odd(fval));
fval := fval DIV 2
END;
gbitcount := gbitcount + fbitsize;
basis↑[gaddr] := intconst
END
END (*PUTNEXTBYTE*);
(** LOAD GETFIELD SELECTOR **)
PROCEDURE load;
(* LOAD VALUE, DESCRIBED BY GATTR, INTO GATTR.CVAL*)
BEGIN
WITH gattr DO
IF kind = varbl THEN
IF typtr <> NIL THEN
IF typtr↑.form <= pointer THEN
BEGIN
kind := expr; cval.ival := nextbyte(gbitcount)
END;
END (*LOAD*);
PROCEDURE getfield( fcp:ctp );
BEGIN
WITH fcp↑, gattr DO
BEGIN
IF klass <> field THEN system_error(3);
CASE packf OF
notpack,
hwordl:
BEGIN
gaddr := gaddr + fldaddr; gbitcount := 0
END;
hwordr:
BEGIN
gaddr := gaddr + fldaddr;
gbitcount := 18
END;
packk:
WITH fldbyte DO
BEGIN
gaddr := gaddr + reladdr;
gbitcount := bitmax - sbits -pbits
END
END (*CASE*);
packfg := packf <> notpack;
typtr := idtype
END (*WITH*)
END (*GETFIELD*);
PROCEDURE expression; FORWARD;
PROCEDURE selector;
LABEL
1;
VAR
lcp: ctp;
lmin, lmax: integer;
lattr: attr;
index, i, indexoffset, bytesinword: integer;
BEGIN
WHILE sy IN [lbrack,arrow,period] DO WITH gattr DO
CASE sy OF
lbrack:
BEGIN
REPEAT
IF typtr <> NIL THEN
IF typtr↑.form <> arrays THEN
BEGIN
error; writeln(tty,'TYPE OF VARIABLE IS NOT ARRAY')
END;
insymbol;
lattr := gattr;
expression;
IF (typtr <> NIL) AND (lattr.typtr<>NIL) THEN
BEGIN
IF comptypes( gattr.typtr, lattr.typtr↑.inxtype ) THEN WITH gattr DO
BEGIN
load;
index := cval.ival;
gattr := lattr;
WITH typtr↑ DO
BEGIN
getbounds(inxtype, lmin, lmax );
indexoffset := index - lmin;
IF indexoffset < 0 THEN i := - indexoffset
ELSE
IF index > lmax THEN
i:= index - lmax
ELSE
GOTO 1;
error; write(tty,'ARRAY-INDEX BY ', i:length(i));
IF indexoffset < 0 THEN writeln(tty, ' LESS THAN LOW BOUND')
ELSE writeln(tty, ' GREATER THAN HIGH BOUND');
1:
IF arraypf THEN
BEGIN
packfg := true;
bytesinword := bitmax DIV aeltype↑.bitsize; i := indexoffset MOD bytesinword;
gaddr := gaddr + (indexoffset DIV bytesinword);
IF indexoffset < 0 THEN
BEGIN
gaddr := gaddr-1;
i := i + bytesinword
END;
gbitcount := i * aeltype↑.bitsize
END
ELSE gaddr := gaddr + (aeltype↑.size * indexoffset);
IF typtr <> NIL THEN typtr := aeltype
END (*WITH TYPTR↑*)
END (*IF COMPTYPES*)
ELSE
BEGIN
error; writeln(tty,'INDEX-TYPE IS NOT COMPATIBLE WITH DECLARATION')
END
END (*IF TYPTR<>NIL*)
UNTIL sy <> comma;
IF sy = rbrack THEN insymbol
ELSE
BEGIN
error; writeln(tty,'"]" EXPECTED')
END;
END;
period:
BEGIN
IF typtr <> NIL THEN
IF typtr↑.form <> records THEN
BEGIN
error; writeln(tty,'TYPE OF VARIABLE IS NOT RECORD')
END;
insymbol;
IF sy = ident THEN
BEGIN
IF typtr <> NIL THEN
BEGIN
searchsection(typtr↑.fstfld, lcp);
IF lcp = NIL THEN
BEGIN
error; writeln(tty,'NO SUCH FIELD IN THIS RECORD')
END
ELSE getfield(lcp)
END (*TYPTR <> NIL*);
insymbol
END
ELSE
BEGIN
error; writeln(tty,'IDENTIFIER EXPECTED')
END
END (*PERIOD*);
arrow:
BEGIN
insymbol;
IF typtr <> NIL THEN
CASE typtr↑.form OF
pointer:
BEGIN
gaddr := nextbyte(18);
IF gaddr = ord(NIL) THEN
BEGIN
error; writeln(tty,'POINTER IS NIL')
END
ELSE
IF (gaddr > ord(accus)) OR
(gaddr < ord(acrpoint(accus↑[0+15B],right))) THEN
BEGIN
error; writeln(tty,'POINTER IS OUT OF HEAP')
END
ELSE
WITH heapcv DO
BEGIN
typtr := typtr↑.eltype;
merkbasis:=acrpoint(gaddr-1,right);
cival:=merkbasis↑[0];
IF (gaddr < ord(cacr) )
AND (ord(cidtype) >= ord(NIL) ) THEN
maxaddr:=ord(cacr)-1
ELSE maxaddr:=ord(NIL);
END (* WITH HEAPCV *);
END;
files:
BEGIN
gaddr := basis↑[gaddr];
typtr := typtr↑.filtype
END;
OTHERS:
BEGIN
error;
writeln(tty,'TYPE OF VARIABLE MUST BE FILE OR POINTER')
END
END (*CASE FORM*);
packfg := false; gbitcount := 0
END (*ARROW*)
END (*CASE*)
END (*SELECTOR*);
(** VARIABLE **)
PROCEDURE variable;
VAR
lcp: ctp;
BEGIN
(*VARIABLE*)
searchid(lcp);
insymbol;
IF lcp = NIL THEN
BEGIN
error; writeln(tty,'NOT FOUND')
END
ELSE
BEGIN
WITH lcp↑, gattr DO
CASE klass OF
types:
BEGIN
error; writeln(tty,'!TYPE')
END;
konst:
BEGIN
kind := cst; cval := values;
typtr := idtype
END;
vars:
BEGIN
kind := varbl;
gaddr := vaddr + ord(basis); basis := nullptr;
gbitcount := 0;
IF vkind = formal THEN gaddr := basis↑[gaddr];
typtr := idtype; packfg := false;
selector
END;
(*FIELD: WRITE(TTY,'NOT IMPL.; TYPE <RECORD>.<FIELD> ...');*)
proc:
BEGIN
error; writeln(tty,'!PROCEDURE')
END;
func:
BEGIN
error; writeln(tty,'!FUNCTION')
END
END (*CASE CLASS*)
END
END (*VARIABLE*);
(** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)
PROCEDURE expression;
PROCEDURE simpleexpression;
VAR
signed: boolean;
lattr: attr;
lop: symbol;
PROCEDURE term;
VAR
lattr: attr;
PROCEDURE factor;
BEGIN
CASE sy OF
ident:
variable;
intconst,
realconst,
charconst:
WITH gattr DO
BEGIN
kind := cst; cval := val;
IF sy = intconst THEN typtr := entry1.intptr
ELSE
IF sy = realconst THEN typtr := entry1.realptr
ELSE typtr := entry1.charptr;
insymbol
END;
stringconst:
WITH gattr DO
BEGIN
typtr := stringptr;
kind := varbl; packfg := false;
gaddr := ord(string); gbitcount := 0;
insymbol
END;
notsy:
BEGIN
insymbol; factor;
WITH gattr DO
IF typtr = entry1.boolptr THEN
BEGIN
load; cval.bval := NOT cval.bval
END
ELSE
BEGIN
error; writeln(tty,'TYPE IS NOT BOOLEAN')
END
END (* NOT *);
lparent:
BEGIN
insymbol; expression;
IF sy = rparent THEN insymbol
ELSE
BEGIN
error;
writeln(tty,'")" EXPECTED')
END
END (* ( *) ;
OTHERS:
BEGIN
error; writeln(tty,'FACTOR EXPECTED')
END
END (* CASE *)
END (*FACTOR*);
BEGIN (*TERM*)
factor;
WHILE sy = mul DO
BEGIN
insymbol;
load; lattr := gattr;
factor; load;
IF comptypes(lattr.typtr,entry1.intptr) AND
comptypes(gattr.typtr,entry1.intptr) THEN gattr.cval.ival := gattr.cval.ival * lattr.cval.ival
ELSE
BEGIN
error; writeln(tty,'OPERANDS MUST BE OF TYPE INTEGER')
END
END
END (*TERM*);
BEGIN (*SIMPLEEXPRESSION*)
IF sy IN [plus,minus] THEN WITH gattr DO
BEGIN
signed := sy=minus ;
insymbol; term;
IF comptypes(typtr,entry1.intptr) OR comptypes(typtr,entry1.realptr) THEN
BEGIN
IF signed THEN
BEGIN
load; cval.ival := - cval.ival
END
END
ELSE
BEGIN
error; writeln(tty,'NO SIGN ALLOWED HERE')
END
END (*MINUS*)
ELSE term;
WHILE sy IN [plus,minus] DO
BEGIN
lop := sy; insymbol;
load; lattr := gattr;
term; load;
IF comptypes(lattr.typtr,entry1.intptr) AND
comptypes(gattr.typtr,entry1.intptr) THEN
IF lop = plus THEN gattr.cval.ival := lattr.cval.ival + gattr.cval.ival
ELSE gattr.cval.ival := lattr.cval.ival - gattr.cval.ival
ELSE
BEGIN
error; writeln(tty,'OPERANDS MUST BE OF TYPE INTEGER')
END
END
END (*SIMPLEEXPRESSION*);
BEGIN
simpleexpression
END (*EXPRESSION*);
(** SHIFTED_OUT WRITESCALAR PUTSIXBIT **)
PROCEDURE shifted_out(name:alfa);
LABEL
1;
VAR
run:integer;
BEGIN
FOR run := 1 TO 10 DO
IF name[run]=' ' THEN GOTO 1
ELSE write(tty,name[run]);
1:
chcnt:=chcnt+run-1;
END (*SHIFTED_OUT*);
PROCEDURE writescalar(fval:integer; fsp: stp);
VAR
lcp: ctp; leng,maxval,minval: integer;
lvalu: valu;
BEGIN
leng:=0;
IF fsp <> NIL THEN WITH fsp↑ DO
CASE form OF
scalar:
IF scalkind=standard THEN
IF fsp=entry1.intptr THEN
BEGIN
leng := length(fval); write(tty, fval:leng)
END
ELSE
IF fsp=entry1.realptr THEN WITH lvalu DO
BEGIN
ival := fval;
write(tty, rval); leng := 17
END
ELSE (*==>CHARPTR*)
BEGIN
IF fsp <> entry1.charptr THEN system_error(4)
ELSE
IF (fval<0) OR (fval>177B) THEN
BEGIN
write(tty,fval:length(fval),' (ILL. CHAR.)');leng:=13+length(fval);
END
ELSE
BEGIN
IF (fval<40B) OR (fval=177B) THEN
BEGIN
ascii_change.ival := fval;
IF fval = 177B THEN ascii_change.ival := 40B;
write(tty,ascii_change.mnemo:3); leng := 3
END
ELSE
BEGIN
write(tty,'''',chr(fval),''''); leng := 3
END
END;
END
ELSE (*SCALKIND==>DECLARED*)
BEGIN
lcp := fconst;
IF fval >= 0 THEN WHILE lcp↑.values.ival > fval DO lcp := lcp↑.next;
WITH lcp↑ DO
IF values.ival <> fval THEN
BEGIN
writescalar(fval,entry1.intptr); write(tty,'(OUT OF RANGE)'); leng := 14
END
ELSE
shifted_out(name);
END;
subrange:
BEGIN
writescalar(fval,rangetype); leng := 0;
IF NOT comptypes(entry1.realptr,rangetype) THEN
BEGIN
IF rangetype<>entry1.intptr THEN
getbounds(rangetype,minval,maxval);
IF (fval <= maxval) AND (fval >= minval) OR (entry1.intptr=rangetype) THEN
BEGIN
getbounds(fsp,minval,maxval);
IF (fval > maxval) OR (fval < minval) THEN
BEGIN
write(tty,'(OUT OF SUBRANGE)');
leng:=17;
END (* IF ..>...<.. *);
END (* IF ..=<..=>..=.. *);
END (* IF COMPTYPES *);
END;
pointer:
IF fval = ord(NIL) THEN
BEGIN
write(tty,'NIL'); leng := 3
END
ELSE
BEGIN
write(tty,fval:6:o,'B');
IF (fval < accus↑[0+15B]) OR (fval > ord(accus)) THEN
BEGIN
write(tty,'(OUT OF HEAP)');
leng:=20;
END
ELSE
leng:=7;
END;
OTHERS:
system_error(5)
END (*CASE*);
chcnt := chcnt + leng;
tabs:=true;
END (*WRITESCALAR*);
PROCEDURE putsixbit(fsixbit:sixbit;fix:integer);
VAR
i:integer;
BEGIN
FOR i:=1 TO fix DO
write(tty,chr(fsixbit[i]+40B));
chcnt:=chcnt+fix;
END;
(** WRITESTRUCTURE WRITEFIELDLIST **)
PROCEDURE writestructure( fsp: stp );
TYPE
ascii=PACKED ARRAY[1..5] OF char;
threebit=PACKED ARRAY[1..12] OF 0..7;
halfword=PACKED ARRAY[leftorright] OF bits18;
filblktyp=RECORD
fileof,filptr:integer;
fileol:boolean;
filsta,filcls,filout,filin,filent,
fillkp,filopn:integer;
fildev:sixbit;
filpbh:halfword;
filext,filnam:sixbit;
filppn,filprot:threebit;
filbtc,filbtp,filbfh:integer;
fillnr:ascii;
filcmp,filcnt:integer
END;
VAR
stinx, inx, i : integer;
llmax, currcompo, lmin, lmax, leng, lspace: integer;
oattr, lattr: attr;
illstring,nexteq, lasteq, zero, nocomma: boolean;
setwandel: RECORD
CASE boolean OF
false: (const1: integer; const2: integer);
true: (mask: SET OF 0..basemax)
END;
filblkwandel:RECORD
CASE boolean OF
true:(int:integer);
false:(ptr:↑filblktyp)
END;
PROCEDURE writefieldlist(fnextfld: ctp; frecvar: stp);
LABEL
1;
VAR
lsp: stp;
j,lmin,lmax : integer;
lattr : attr;
tagf : ctp;
BEGIN
lattr := gattr; tagf := NIL;
IF frecvar <> NIL THEN
IF frecvar↑.form = tagfwithid THEN tagf := frecvar↑.tagfieldp;
WHILE (fnextfld <> NIL) AND (fnextfld <> tagf) DO
BEGIN
newline;
getfield(fnextfld);
WITH fnextfld↑ DO
BEGIN
shifted_out(name);write(tty,'=');
chcnt:=chcnt+1;
nl := true;
leftspace:=leftspace+2;
writestructure(idtype);
leftspace:=leftspace-2;
fnextfld := next
END;
IF fnextfld<>NIL THEN
WITH fnextfld↑.idtype↑ DO
IF form=arrays THEN
BEGIN
getbounds(inxtype,lmin,lmax);
tabs:=arraypf AND tabs AND
comptypes(aeltype , entry1.charptr) AND
(lmax-lmin <= 20 )
END
ELSE
tabs:=tabs AND (form<=pointer)
ELSE
tabs:=false;
gattr := lattr
END (*WHILE*);
IF tagf <> NIL THEN
BEGIN
WITH tagf↑ DO
BEGIN
newline;
shifted_out(name);
write(tty,'=');
chcnt:=chcnt+1;
getfield( tagf );
j := nextbyte(idtype↑.bitsize);
writescalar(j, idtype);
write(tty,' (TAGFIELD)');
chcnt:=chcnt+11;
END;
lsp := frecvar↑.fstvar;
tabs:=false;
LOOP
IF lsp = NIL THEN
BEGIN
write(tty,'(NO CORRESP.VARIANT)'); GOTO 1
END
EXIT IF lsp↑.varval.ival = j;
lsp := lsp↑.nxtvar
END (*LOOP*);
WITH lsp↑ DO
BEGIN
IF form <> variant THEN
system_error(6);
gattr := lattr;
writefieldlist( firstfield, subvar );
tabs:=false;
END;
1:
END
END (*WRITEFIELDLIST*);
BEGIN
(*WRITESTRUCTURE*)
IF fsp <> NIL THEN WITH fsp↑ DO
IF form <= pointer THEN writescalar ( nextbyte(bitsize), fsp )
ELSE
BEGIN
lattr := gattr;
WITH gattr DO
BEGIN
IF gbitcount > 0 THEN
BEGIN
gaddr := gaddr + 1; gbitcount := 0
END;
CASE form OF
power:
BEGIN
nocomma := true; write(tty, '['); leng := 1;
WITH setwandel DO
BEGIN
const1 := basis↑[gaddr]; const2 := basis↑[gaddr+1];
FOR inx := 0 TO basemax DO
IF inx IN mask THEN
BEGIN
IF nocomma THEN nocomma := false
ELSE write(tty,',');
leng := leng + 1;
IF comptypes(elset,entry1.charptr) THEN i := inx + offset
ELSE i := inx;
writescalar(i,elset)
END
END (*WITH SETWANDEL*);
write(tty,']' ); chcnt := chcnt + leng;
tabs:=false;
END (*POWER*);
arrays:
BEGIN
illstring:=false;
getbounds(inxtype, lmin, lmax );
IF ( gaddr > ord(acrpoint(accus↑[0+15B],right))) (* DYNAMIC ALLOCATED *)
AND ( gaddr <= ord(NIL) ) (* NOT A CONSTANT *) THEN
BEGIN
IF maxaddr > ord(accus) THEN maxaddr := ord(accus);
IF arraypf THEN
llmax := (maxaddr-gaddr+1) * (36 DIV aeltype↑.bitsize) + lmin - 1
ELSE
llmax := (maxaddr-gaddr+1) DIV aeltype↑.size + lmin - 1;
IF llmax < lmax THEN lmax := llmax;
END;
leng := lmax - lmin + 1 ;
IF comptypes(aeltype , entry1.charptr) AND arraypf AND (leng<121) THEN
BEGIN
pointercv.addr := gaddr;
inx:=1;
WITH pointercv DO
WHILE (inx<=leng) DO
IF (stringptr↑[inx] < chr(40B (*' '*))) OR (stringptr↑[inx] > chr(172B (* LOWER-Z *))) THEN
inx:=122
ELSE inx:=inx+1;
IF inx = 122 THEN
BEGIN
illstring:=true;
write(tty,'STRING CONT. ILL. CHAR');
tabs:=false;
leftspace:=leftspace+2;
newline;
write(tty,'THE COMPONENTS ARE:');
nl:=true;
END;
END (* TEST ILLSTRING *);
IF comptypes(aeltype , entry1.charptr) AND arraypf AND (leng<121) AND NOT illstring THEN (*STRING*)
BEGIN
write ( tty, '''', pointercv.stringptr↑ : leng, '''' ) ;
chcnt := chcnt + leng + 2;
tabs:= (leng <= 20);
END (*STRING*)
ELSE
BEGIN
tabs:=false;
packfg:=arraypf;
lasteq:=false;
FOR inx:= lmin TO lmax DO
BEGIN
IF inx=lmax THEN nexteq:=false
ELSE
IF aeltype↑.form <= pointer THEN
BEGIN
oattr:=gattr;
currcompo:=nextbyte(aeltype↑.bitsize);
nexteq:=currcompo = nextbyte(aeltype↑.bitsize);
gattr:=oattr;
END
ELSE
BEGIN
nexteq:=true;i:=0;
LOOP
nexteq:=(basis↑[gaddr+i] = basis↑[gaddr+aeltype↑.size+i]);
EXIT IF NOT nexteq OR (i = aeltype↑.size-1);
i:=i+1;
END;
END (* FORM>POINTER *);
IF NOT(lasteq AND nexteq) THEN
BEGIN
IF nl THEN newline
ELSE nl:=true;
write(tty,'['); writescalar(inx,inxtype);
write(tty,']'); chcnt:=chcnt+2;
END;
IF NOT nexteq THEN
BEGIN
write(tty,'=');chcnt:=chcnt+1;
leftspace:=leftspace + 3;
nl:=true;
writestructure(aeltype);
leftspace:=leftspace - 3;
END
ELSE
BEGIN
IF NOT lasteq THEN
BEGIN
write(tty,'..');
chcnt:=chcnt+2;
nl:=false;
END;
IF aeltype↑.form <= pointer THEN currcompo:=nextbyte(aeltype↑.bitsize)
ELSE gaddr:=gaddr+aeltype↑.size;
END (* NEXTEQ *);
lasteq:=nexteq;
END (* FOR *);
tabs:=false;
IF illstring THEN leftspace := leftspace - 2;
END (* NOT STRING *);
END (*ARRAYS*);
records:
BEGIN
write(tty,'RECORD');
lspace := leftspace; leftspace := chcnt + 1;
tabs:=false;
writefieldlist(fstfld,recvar);
tabs:=false;
leftspace := leftspace - 1; newline;
write(tty,'END');
leftspace := lspace;
END;
files:
WITH filblkwandel DO
BEGIN
IF nl THEN
newline;
tabs:=true;
int:=gaddr;
WITH ptr↑, gattr DO
IF (filpbh[left]=0) AND (filpbh[right]=0) THEN
BEGIN
write(tty,' FILE NOT OPENED');
END
ELSE
BEGIN
shifted_out('DEVICE: ');
putsixbit(fildev,6);
newline;
shifted_out('NAME: ');
putsixbit(filnam,6);
shifted_out('. ');
putsixbit(filext,3);
newline;
shifted_out('PPN:[ ');
stinx:=1;
LOOP
zero:=true;
FOR inx:=stinx TO stinx+5 DO
IF NOT(zero AND (filppn[inx]=0)) OR (inx=stinx+5) THEN
BEGIN
zero:=false;
write(tty,chr(filppn[inx]+ord('0')));
chcnt:=chcnt+1;
END;
EXIT IF stinx=7;
stinx:=7;write(tty,',');
END;
write(tty,']');chcnt:=chcnt+2;
newline;
shifted_out('PROT:< ');
FOR inx:=1 TO 3 DO
write(tty,chr(filprot[inx]+60B));
write(tty,'>');
chcnt:=chcnt+4;
newline;
shifted_out('STATUS: ');
IF filsta=0 THEN shifted_out('ASCII ')
ELSE shifted_out('BINARY ');
newline;
shifted_out('MODE(I/O):');
IF filpbh[left]<>0 THEN shifted_out('OUTPUT ')
ELSE shifted_out('INPUT ');
newline;
IF filpbh[left]=0 THEN
BEGIN
IF filsta=0 THEN
BEGIN
IF fillnr<>'-----' THEN
BEGIN
shifted_out('LINENR.: ');
write(tty,fillnr);
chcnt:=chcnt+5;
newline;
END;
write(tty,'EOLN:',fileol:5);
chcnt:=chcnt+10;
newline;
END (* FILSTA = 0 *);
write(tty,'EOF:',(fileof<>0):5);
chcnt:=chcnt+9;
newline;
END (* FILPBH[LEFT]=0 *);
gaddr:=filptr;
typtr := typtr↑.filtype;
tabs:=false;
IF chcnt<>leftspace THEN newline;
shifted_out('COMPONENT:');
nl:=true;
writestructure(typtr);
END (* WITH PTR↑ *);
tabs:=false;
END (* FILBLKWANDEL *)
END (*CASE FORM*)
END (*WITH GATTR*);
gattr := lattr;
WITH gattr DO
BEGIN
gaddr := gaddr + size; gbitcount := 0
END
END (*IF FORM > POINTER*)
END (*WRITESTRUCTURE*);
(** ASSIGNMENT **)
PROCEDURE assignment;
VAR
lattr: attr;
lsp: stp;
byte, i: integer;
BEGIN
IF gattr.kind <> varbl THEN
BEGIN
error; writeln(tty,'ASSIGNMENT ALLOWED TO VARIABLES ONLY')
END
ELSE
BEGIN
lattr := gattr;
expression;
IF sy <> eolsy THEN
BEGIN
error; writeln(tty,'<CR><LF> EXPECTED')
END
ELSE
IF comptypes( lattr.typtr, gattr.typtr ) THEN
BEGIN
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
IF lattr.packfg THEN
BEGIN
load; byte := gattr.cval.ival;
gattr := lattr;
putnextbyte( gattr.typtr↑.bitsize, byte )
END (* IF PACKFG *)
ELSE
IF gattr.kind <> varbl THEN basis↑[lattr.gaddr] := gattr.cval.ival
ELSE
IF gattr.packfg THEN basis↑[lattr.gaddr] := nextbyte( gattr.typtr↑.bitsize )
ELSE FOR i := 0 TO lattr.typtr↑.size - 1 DO
basis↑[lattr.gaddr + i ] := basis↑[ gattr.gaddr + i ]
END (* IF COMPTYPES *)
ELSE
BEGIN
error; writeln(tty, 'TYPE-CONFLICT IN ASSIGNMENT' )
END
END (* KIND=VARIABLE *)
END (*ASSIGNMENT*);
(** STOPSEARCH PAGEVALUE LINEVALUE BREAKPOINT GETLINPAG **)
FUNCTION stopsearch(fline:addrrange):integer;
LABEL
1;
VAR
i: integer;
BEGIN
FOR i := 1 TO stopmax DO WITH stoptable[i] DO
IF (page=gpage) AND (thisline=fline) THEN
BEGIN
stopsearch := i;
GOTO 1(*EXIT*)
END;
stopsearch := 0; (*NOT FOUND*)
1:
END (*STOPSEARCH*);
FUNCTION pagevalue(fpager: pageelem): integer;
BEGIN
WITH fpager DO pagevalue := ac*16 + inxreg
END (*PAGEVALUE*);
FUNCTION linevalue ( VAR fliner: lineelem; fline: integer) : integer;
LABEL
1;
VAR
i: integer;
BEGIN
WHILE fliner.code = 260B(*PUSHJ*) DO
BEGIN
i := stopsearch( fline );
IF i = 0 THEN
BEGIN
writeln(tty,'$ STOPTABLE DESTROYED'); linevalue := -1; GOTO 1
END;
fliner.constant1 := stoptable[i] . originalcont
END (*PUSHJ*);
WITH fliner DO
IF code = 320B(*JUMP*) THEN linevalue := fline - ( ac + 16*inxr )
ELSE (*SKIPA*)
BEGIN
IF code <> 334B(*SKIPA*) THEN
BEGIN
system_error(7);
linevalue := -1; GOTO 1
END;
IF absline = 777777B THEN linevalue := -1
ELSE linevalue := absline
END;
1:
END (*LINEVALUE*) ;
PROCEDURE breakpoint;
LABEL
1;
VAR
linenr, i: integer;
pager: pageelem; lle: lineelem;
lline,lpage: integer;
oldline: integer;
oldaddr: ↑lineelem;
changeptr: ↑lineelem;
FUNCTION getlinpag: boolean; (*READS LINENUMBER AND PAGENUMBER*)
BEGIN
getlinpag := false;
IF sy <> intconst THEN writeln(tty,'$ ILL. LINENR.')
ELSE
BEGIN
linenr := val.ival; gpage := 1(*DEFAULT*);
insymbol;
IF sy = slashsy THEN
BEGIN
insymbol;
IF sy <> intconst THEN writeln(tty,'$ ILL. PAGENR.')
ELSE
BEGIN
gpage := val.ival; insymbol
END
END;
IF sy <> eolsy THEN writeln(tty,'$ COMMAND ERROR')
ELSE getlinpag := true
END
END (*GETLINPAG*);
BEGIN
(*BREAKPOINT*)
CASE sy OF
ident:
IF id = 'LIST ' THEN
BEGIN
insymbol;
IF sy <> eolsy THEN writeln(tty,'$ COMMAND ERROR')
ELSE FOR i := 1 TO stopmax DO WITH stoptable[i] DO
IF page > 0 THEN writeln(tty,'$ ', thisline:5, '/', page:length(page))
END
ELSE
writeln(tty,'$ COMMAND ERROR');
notsy:
BEGIN
insymbol;
IF getlinpag THEN
BEGIN
i:=stopsearch(linenr);
IF i = 0 THEN writeln(tty, '$ ?NO STOP')
ELSE WITH stoptable[i] DO
BEGIN
page := 0;
protection(false);
thisaddr↑.constant1 := originalcont;
protection(true);
thisaddr := NIL
END
END
END;
intconst:
IF getlinpag AND ( stopsearch(linenr) = 0 (*A NEW STOP*) ) THEN
BEGIN
stopnr := 1;
WHILE stoptable[stopnr].page <> 0 DO stopnr := stopnr + 1;
IF stopnr > stopmax THEN writeln(tty,'$ TOO MUCH STOPS')
ELSE
BEGIN
(*EXECUTE STOP*)
(*1.STEP: SEARCH PAGE*)
pager := entry1.lastpageelem;
lpage := pagevalue(pager);
IF lpage < gpage THEN writeln(tty,'$ PAGENR. TOO LARGE')
ELSE
BEGIN
WHILE lpage > gpage DO
BEGIN
pager := pager.pagptr↑;
lpage := pagevalue(pager)
END;
IF lpage <> gpage THEN
BEGIN
writeln(tty,'$ CAN''T STOP ON THIS PAGE'); GOTO 1
END;
WITH lle, pager DO
BEGIN
lline := lastline; adp := laststop
END;
IF lline < linenr THEN writeln(tty,'$ LINENR. TOO LARGE')
ELSE
BEGIN
WHILE lline > linenr DO
BEGIN
oldline := lline; oldaddr := lle.adp;
lle := lle.adp↑;
lline := linevalue ( lle, lline )
END;
IF lline <> linenr THEN
BEGIN
write(tty,'$ NEXT POSSIBLE: ',oldline:length(oldline),' (Y OR N)? ');
break; readln(tty);
insymbol;
IF (sy <> ident) OR (id[1] <> 'Y') OR (stopsearch(oldline) <> 0) THEN GOTO 1;
lle.adp := oldaddr; lline := oldline
END;
changeptr := lle.adp;
WITH stoptable[stopnr] DO
BEGIN
thisline := lline; page := gpage;
originalcont := changeptr↑.constant1;
thisaddr := changeptr
END;
protection(false);
changeptr↑.constant1 := entry2.stoppy;
protection(true)
END
END
END;
1:
END (*INTCONST*);
OTHERS:
writeln(tty,'$ COMMAND ERROR')
END (*CASE*)
END (*BREAKPOINT*);
(** LINEINTERVAL STOPMESSAGE TRACEOUT ONE_VAR_OUT **)
PROCEDURE lineinterval(faddr: addrrange; VAR lin1,lin2,pag: integer);
VAR
pager: pageelem; liner: lineelem;
BEGIN
pager := entry1.lastpageelem;
WHILE ord(pager.pagptr) > faddr DO
pager := pager.pagptr↑;
liner.adp := pager.laststop;
pag := pagevalue(pager); lin2 := pager.lastline;
lin1 := lin2;
WHILE ord ( liner.adp ) > faddr DO
BEGIN
liner := liner.adp↑;
lin2 := lin1;
lin1 := linevalue(liner,lin2)
END;
IF lin1<0 THEN lin1 := 0
END (*LINEINTERVAL*);
PROCEDURE stopmessage(faddr: addrrange);
VAR
lin1, lin2, pag: integer;
BEGIN
lineinterval(faddr,lin1,lin2,pag);
writeln(tty, '$ STOP IN ', lin1:length(lin1), '/', pag:length(pag), ':',lin2:length(lin2) )
END (*STOPMESSAGE*) ;
PROCEDURE traceout;
VAR
i: 0:5; lcp: ctp;
laddr: addrrange;
lin1, lin2, pag, maxnames: integer;
BEGIN
tabs:=false;
IF dump THEN
BEGIN
newline;
writeln(tty,' ':39,'PROCEDURE BACKTRACING');
write(tty,'$',' ':40,'=====================');
newline;
writeln(tty);maxnames:=5;
END
ELSE
maxnames:=2;
firstbasis; i := 0; leftspace := 0;
laddr := entry2.status.returnaddr;
write(tty,'$ ');
LOOP
lineinterval ( laddr, lin1, lin2, pag ) ;
write(tty,lin1:5,'/',pag:length(pag),' ')
EXIT IF basis = nullptr;
lcp := idtree;
IF lcp<>NIL THEN
write(tty, lcp↑.next↑.name )
ELSE
write(tty,'''NO NAME'' ');
IF i = maxnames THEN
BEGIN
newline; i := 0
END
ELSE
BEGIN
write(tty,' _ '); i := i + 1
END;
laddr := ord ( acrpoint(basis↑[0]-1,right) );
succbasis( left(*=DYNAMIC*) )
END;
writeln(tty, 'MAIN')
END (*TRACEOUT*);
PROCEDURE one_var_out(lcp:ctp);
BEGIN
WITH lcp↑,gattr DO
BEGIN
kind:=varbl;
gaddr:=vaddr+ord(merkbasis);
gbitcount:=0;
IF vkind=formal THEN
gaddr:=nullptr↑[gaddr];
typtr:=idtype;
packfg:=false;
shifted_out(name);
write(tty,'=');
chcnt:=chcnt+1;
IF idtype↑.form > power THEN
BEGIN
nl:=true;
leftspace:=2;
END;
writestructure(idtype);
IF idtype↑.form >= power THEN
BEGIN
leftspace:=0;
tabs:=false;
newline;
END;
newline;
END (* WITH *);
END (* ONE_VAR_OUT *);
(** SECTION_OUT OUT **)
PROCEDURE section_out(lcp:ctp;fformset:formset);
BEGIN
WITH lcp↑ DO
BEGIN
IF llink<>NIL THEN
section_out(llink,fformset);
IF (klass=vars) AND (idtype↑.form IN fformset) THEN
one_var_out(lcp);
IF rlink<>NIL THEN
section_out(rlink,fformset);
END (* WITH *);
END (* SECTION_OUT *);
PROCEDURE out(side:leftorright);
VAR
callcnt:integer;
treepnt:ctp;
lowestdynamicbasis,staticbasis:acr;
varsout:boolean;
BEGIN
callcnt:=1;
chcnt:=0;
tabs:=false;
lowestdynamicbasis:=merkbasis;
firstbasis;
staticbasis:=basis;
LOOP
merkbasis:=basis;
treepnt:=idtree;
basis:=nullptr;
varsout:=true;
IF merkbasis=nullptr THEN
write(tty,' * * * * * * * * MAIN')
ELSE
IF treepnt=NIL THEN
write(tty,'P R O C E D U R E ''NO NAME'' ')
ELSE
IF treepnt↑.next <> NIL THEN
IF treepnt↑.next↑.klass = func THEN write(tty,'F U N C T I O N ',treepnt↑.next↑.name)
ELSE write(tty,'P R O C E D U R E ',treepnt↑.next↑.name);
newline;
write(tty,'- - - - - - - - - - - - - - - -');
newline;
IF (side = left) AND (staticbasis = merkbasis) AND (merkbasis <> nullptr) THEN
BEGIN
write(tty,'THE FOLLOWING VARIABLES ARE VALID');newline;
write(tty,' IN THE INTERRUPTED PROCEDURE ');
newline;newline;
basis:=staticbasis;
succbasis(right);
staticbasis:=basis;
basis:=nullptr;
END
ELSE
IF (side = right) AND (ord(lowestdynamicbasis) <= ord(merkbasis)) THEN
BEGIN
write(tty,'LOOK ABOVE ( VAR. OF CALLED PROC.) ');
newline; varsout:=false;
END;
IF (treepnt = NIL) AND varsout THEN
BEGIN
write(tty,' THERE IS NO INFORMATION ABOUT' );newline;
write(tty,' THIS PART OF THE PROGRAMM ( LOCAL D- ??)');
newline; varsout:=false;
END (* TREEPTR=NIL ....*);
IF varsout AND (merkbasis<>nullptr) THEN treepnt:=treepnt↑.llink;
IF varsout THEN
IF treepnt<>NIL THEN
BEGIN
section_out(treepnt,[scalar,subrange,pointer]);
tabs:=false;
IF chcnt<>0 THEN newline;
newline;
section_out(treepnt,[power,arrays,records,files]);
tabs:=false;
END (* TREEPNT<>NIL *)
ELSE
BEGIN
write(tty,'+++ NO VARIABLES +++');
newline;newline;
END;
newline;newline;
EXIT IF (merkbasis=nullptr) OR (callcnt=10);
callcnt:=callcnt+1;
basis:=merkbasis;
succbasis(side);
END (* LOOP *);
IF merkbasis=nullptr THEN
section_out(entry1.standardidtree,[files]);
END (* OUT *);
(** STACK_OUT HEAP_OUT **)
PROCEDURE stack_out;
BEGIN
newline;newline;
writeln(tty,' ':40,'VARIABLES OF THE CALLED PROCEDURE(S)');
write(tty,'$',' ':41,'====================================');
newline;newline;
out(left);
IF merkbasis<>nullptr THEN
BEGIN
newline;newline;
write(tty,' BECAUSE THERE ARE MORE THAN 10 DYNAMIC NESTED PROCEDURES AND/OR FUNCTIONS');
newline;
write(tty,' NOW ONLY THE VARIABLES OF THE STATIC NESTED PROCEDURES AND/OR FUNCTIONS ');
newline;write(tty,' WILL BE PRINTED OUT');newline;
newline;newline;newline;
writeln(tty,' ':40,'VARIABLES OF STATIC NESTED PROCEDURES');
write(tty,'$',' ':41,'=====================================');
newline;newline;newline;
out(right);
END (*BASIS<>.. *);
END (* ALL_VAR_OUT *);
PROCEDURE heap_out;
VAR
rec:acr;
BEGIN
newline;
writeln(tty,' ':39,'THE CONTENTS OF THE HEAP');
write(tty,'$ ',' ':39,'========================');
newline;
tabs:=false;
rec:=acrpoint(accus↑[0+15B],right);
WITH heapcv DO
BEGIN
cival:=rec↑[0];
IF (cidtype=NIL) AND (cacr=NIL) THEN
BEGIN
newline;
write(tty,' NO VARIABLES ALLOCATED');
newline;
END
ELSE
WHILE cacr<>NIL DO
BEGIN
IF (ord(cacr) > ord(accus)) OR
(ord(cacr) <= accus↑[0+15B]) OR
(ord(cacr) <= ord(rec)) OR
(ord(cidtype) < ord(NIL)) OR
(ord(cidtype) > ord(entry2.entryptr)) THEN
BEGIN
newline;
write(tty,' CANT CONTINUE THE HEAP-DUMP');
cacr:=NIL;
newline;
END
ELSE
BEGIN
newline;
write(tty,(ord(rec)+1):6:o,'B↑=');
chcnt:=chcnt+9;
IF cidtype=NIL THEN
BEGIN
newline;
write(tty,' TYPE OF REFERENCED VARIABLE NOT KNOWN');
newline;
END
ELSE
WITH gattr DO
BEGIN
nl:=true;
typtr:=cidtype;
kind:=varbl;
packfg:=false;
gaddr:=ord(rec)+1;
maxaddr:=ord(cacr) - 1;
gbitcount:=0;
writestructure(cidtype);
END (* WITH GATTR *);
tabs:=false;
rec:=cacr;
cival:=rec↑[0];
newline;
END (* POINTER OK *);
END (* WHILE *);
END (* WITH HEAPCV *);
newline;
END (* HEAP_OUT *);
(** WRITE_PROGRAM_NAME HEADER BACK_TO_TTY CORRECT_ADDR RIGHT_ADDR **)
PROCEDURE write_program_name;
BEGIN
WITH pointercv DO
BEGIN
addr := ord(acrpoint(entry2.name_pnt_pnt↑[0],right));
shifted_out(alfapnt↑);
END;
writeln(tty)
END (* WRITE_PROGRAM_NAME *);
PROCEDURE header;
BEGIN
leftspace:=0;
dump:=true;
time(day_time);
date(day);
file_name:=' PMD';
file_name[1]:=day_time[1];
file_name[2]:=day_time[2];
file_name[3]:=day_time[4];
file_name[4]:=day_time[5];
file_name[5]:=day_time[7];
file_name[6]:=day_time[8];
IF entry2.interactive THEN
device:='DSK '
ELSE device:='LPT ';
rewrite(ttyoutput,file_name,0,0,device);
newline;
write(tty,day:20,day_time:20,'PROGRAM-NAME ':20);
write_program_name;
write(tty,'$ ');
END (* HEADER *);
PROCEDURE back_to_tty;
BEGIN
tabs:=false;
dump := false;
rewrite(ttyoutput,'123456789',0,0,'TTY ');
IF entry2.interactive THEN write(tty,'$');
newline;
newline;
writeln(tty,'LOOK FOR DUMP ON FILE ',file_name:6,
'.',file_name[7],file_name[8],file_name[9]);
END (* BACK_TO_TTY *);
PROCEDURE correct_addr;
VAR
pagepointer:↑pageelem;
FUNCTION right_addr:addrrange;
VAR
help:integer;
lacr:acr;
BEGIN
firstbasis;
IF basis=nullptr THEN right_addr:=ord(acrpoint(entry2.stackbottom↑[0+2]-1,right))
ELSE
BEGIN
lacr:=acrpoint(basis↑[0]-1,right);
help:=lacr↑[0];
REPEAT
help:=help+1;
lacr:=acrpoint(help,right);
UNTIL ord(acrpoint(lacr↑[0],left))=541757B (*HRRI 17,?(17)*);
help:=ord(acrpoint(lacr↑[0],right));
right_addr:=ord(acrpoint(basis↑[help+1]-1,right));
END;
END (* RIGHT_ADDR *);
BEGIN
WITH entry1,entry2.status DO
BEGIN
IF ord(entry2.entryptr) <= returnaddr THEN
returnaddr:=right_addr
ELSE
BEGIN
pagepointer:=lastpageelem.pagptr;
IF ord(pagepointer) <> 0 THEN
WHILE ord(pagepointer↑.pagptr) <> 0 DO
pagepointer:=pagepointer↑.pagptr;
IF (ord(pagepointer) > returnaddr) OR ( ord(pagepointer) = 0 ) THEN
returnaddr:=right_addr;
END (* ELSE *);
END (* WITH *);
END (* CORRECT_ADDR *);
(** INIT DEBUG_INTERACTIVE **)
PROCEDURE init;
BEGIN
WITH pointercv DO
BEGIN
addr := 140B;
entry2 := entptr2↑
END;
entry1 := entry2.entryptr↑;
accus := entry2.registrs;
nullptr := acrpoint(0,right);
IF entry2.status.kind IN [ddtk,runtmerrk] THEN correct_addr;
laddr := entry2.status.returnaddr;
END (*INIT*);
PROCEDURE debug_interactive;
LABEL
1;
VAR
open_tty: boolean;
BEGIN
writeln(tty);
break;
open_tty := true;
CASE entry2.status.kind OF
initk:
BEGIN
id := 'TTY '; variable; (*FILEBLOCK(TTY)-->GATTR*)
IF basis↑[gattr.gaddr+13B] = 0 THEN
open_tty := false;
(* TO BE SURE THAT THE TTY-INPUT FILE HAS BEEN OPENED *)
write(tty, version:5,': ');
write_program_name;
END;
stopk:
BEGIN
FOR stopnr := 1 TO stopmax DO
WITH stoptable[stopnr] DO
IF ord(thisaddr) = laddr THEN
BEGIN
write(tty,'$ STOP AT ', thisline:length(thisline), '/', page:length(page),' IN ');
write_program_name;
GOTO 1
END;
stopmessage(laddr); (*,IF NOT FOUND*)
1:
END;
ddtk:
BEGIN
write(tty, '$ STOP BY DDT COMMAND IN ');
write_program_name;
stopmessage(laddr)
END;
haltk, runtmerrk:
BEGIN
IF entry2.status.kind = runtmerrk THEN
write(tty,'$ STOP BY RUNTIME ERROR IN ')
ELSE
write(tty,'$ STOP BY HALT IN ');
write_program_name;
stopmessage(laddr)
END
END (*CASE*);
bufflng := 0;
WHILE NOT eoln(tty) AND open_tty DO
BEGIN
bufflng := bufflng + 1;
(*READ ( TTY, BUFFER[BUFFLNG] )*) buffer[bufflng] := tty↑; get(tty)
END;
REPEAT
REPEAT
write(tty,'$'); break;
IF open_tty THEN readln(tty)
ELSE
BEGIN
open_tty := true;
reset(tty,'TTY ',0,0,'TTY ');
END;
UNTIL NOT eoln(tty);
read(tty,ch); chcnt := 0;
insymbol;
CASE sy OF
stopsy:
BEGIN
insymbol;
breakpoint
END;
stackdumpsy,
heapdumpsy:
BEGIN
header;
writeln(tty);
stopmessage(laddr);
write(tty,'$');
newline;
traceout;
write(tty,'$ ');
IF sy=stackdumpsy THEN stack_out
ELSE heap_out;
back_to_tty;
END;
tracesy:
traceout;
ident, notsy, (*EXPRESSION-BEGIN-SYMBOLS*)
intconst, realconst, charconst, stringconst, plus, minus,
lparent:
BEGIN
expression;
CASE sy OF
eqsy:
WITH gattr DO
IF typtr <> NIL THEN
BEGIN
write(tty,'$ ');
chcnt := 0; leftspace := 0; nl := false;
IF kind <> varbl THEN
IF typtr↑.form = arrays THEN
BEGIN
gaddr := cval.ival;
basis := nullptr;
writestructure ( typtr )
END
ELSE writescalar(cval.ival,typtr)
ELSE writestructure( typtr );
writeln(tty)
END;
becomes:
BEGIN
insymbol; assignment
END;
OTHERS:
BEGIN
error; writeln(tty, '"=" OR ":=" EXPECTED')
END
END (*CASE*)
END;
endsy, eolsy: (*EMPTY*) ;
OTHERS:
writeln(tty,'$ COMMAND ERROR')
END (*CASE*)
UNTIL sy=endsy;
IF entry2.status.kind IN [runtmerrk,haltk] THEN writeln(tty,'$ CANNOT CONTINUE')
ELSE
BEGIN
WHILE sy <> eolsy DO insymbol;
IF (bufflng > 0) AND (entry2.status.kind <> ddtk) THEN WITH gattr DO
BEGIN
id := 'TTY '; variable; (*FILEBLOCK(TTY)-->GATTR*)
basis↑[gaddr+25B(*FILCMP*)] := ord(buffer[1]);
basis↑[gaddr+ 2B(*FILEOL*)] := ord(false);
basis↑[gaddr+22B(*FILBTC*)] := bufflng + 2;
laddr := basis↑[gaddr+20B(*FILBFH*)]+2; (*ADDR OF 1ST DATA*)
basis↑[gaddr+21B(*FILBTP*)] := 010700000000B + laddr -1;
gaddr := laddr; packfg:= true;
FOR chcnt := 2 TO bufflng DO putnextbyte(7,ord(buffer[chcnt]));
putnextbyte(7,015B); putnextbyte(7,012B); (*<CR><LF>*)
FOR chcnt := 1 TO 4 DO putnextbyte(7,0);
(*CLEAR WITH NULL*)
writeln(tty,'$ INPUT RESCANNED(!) : ', buffer:bufflng);
break
END;
writeln(tty)
END
END (*DEBUG_INTERACTIVE*);
(** DEBUG_BATCH ] DEBUG **)
PROCEDURE debug_batch;
BEGIN
CASE entry2.status.kind OF
initk:
WITH pointercv DO
BEGIN
write(tty,version:5,': ');
write_program_name;
addr:=140B;
entptr2↑.time_limit:= 4 * ((entry2.time_limit + clock) DIV 5);
break;
END;
haltk, runtmerrk:
BEGIN
header;
newline;
newline;
writeln(tty,'***************************************************':90);
writeln(tty,'$','*':41,'*':50);
writeln(tty,'$','*':41,'*':50);
writeln(tty,'$','*':41,' P O S T - M O R T E M - D U M P *':51);
writeln(tty,'$','*':41,version:34,'*':16);
writeln(tty,'$','*':41,'*':50);
writeln(tty,'$','***************************************************':91);
write(tty,'$');
newline;
writeln(tty);
stopmessage(laddr);
write(tty,'$ ');
IF entry2.status.kind = haltk THEN write(tty,'STOP BY HALT')
ELSE write(tty,'STOP BY RUNTIME ERROR');
newline;
newline;
traceout;
write(tty,'$');
stack_out;
newline;
heap_out;
write(tty,' END OF POST - MORTEM - DUMP');
back_to_tty;
END;
OTHERS:
writeln(tty,'$ POST-MORTEM-DUMP ERROR')
END;
END;
(*!!!!!!!!!!!!!!!!!!!!!! DEBUG !!!!!!!!!!!!!!!!!!!!!!!!*)
BEGIN
init;
IF entry2.interactive THEN
debug_interactive
ELSE
debug_batch;
END (*debug*);
BEGIN
END.
PROGRAM status, getstatus;
(*******************************************************************************
*
* PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
*
* PROCEDURE GETSTATUS
*
* - ASSIGN APPROPRIATE VALUES TO
* "FILENAME", "PROTECTION", "UFD" AND "DEVICE"
* AS FOUND IN "FILE_BLOCK".
*
* GETSTATUS IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO
* EVERY PASCAL USER.
*
******************************************************************************)
TYPE
leftorright = (left,right);
ascii = PACKED ARRAY[1..5] OF char;
pack6 = PACKED ARRAY[1..6] OF char;
pack9 = PACKED ARRAY[1..9] OF char;
threebit = PACKED ARRAY[1..12] OF 0..7;
halfword = PACKED ARRAY[leftorright] OF 0..777777B;
sixbit = PACKED ARRAY[1..6] OF 0..77B;
fileblockpointer = ↑fileblock;
fileblock = RECORD
fileof,filptr:integer;
fileol:boolean;
filsta,filcls,filout,filin,filent,
fillkp,filopn:integer;
fildev:sixbit;
filpbh:halfword;
filext,filnam:sixbit;
filprot:threebit;
filppn: integer;
filbtc,filbtp,filbfh:integer;
fillnr:ascii;
filcmp,filcnt:integer
END;
PROCEDURE getstatus(file_block: fileblockpointer;
VAR filename: pack9;
VAR protection, ufd: integer;
VAR device: pack6);
VAR
i: integer;
BEGIN
(*GETSTATUS*)
WITH file_block↑ DO
BEGIN
ufd := filppn;
protection := 0;
FOR i := 1 TO 3 DO protection := protection*10B + filprot[i];
FOR i := 1 TO 6 DO filename[i] := chr(filnam[i] + 40B);
FOR i := 1 TO 3 DO filename[i+6] := chr(filext[i] + 40B);
FOR i := 1 TO 6 DO device[i] := chr(fildev[i] + 40B)
END
END (*GETSTATUS*);
BEGIN
END.
PROGRAM read, readscalar, readirange,
readcrange, readrrange, readiset, readcset, readdset, readstr;
(************************************************************************************
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG 13
* GERMANY
* 1976
*
* PASCAL RUNTIME SYSTEM
* (FROM KISICKI, 29-JUL-76)
*
* EXTENDED FORMATTED INPUT
*
* - READSCALAR : READ IDENTIFIERS OF DECLARED SCALARS
*
* - READIRANGE,
* READCRANGE,
* READRRANGE : READ SUBRANGE OF INTEGER, CHAR OR REAL
* WITH BOUNDARY CHECKS
*
* - READISET,
* READCSET,
* READDSET : READ SETS OF INTEGER, CHAR OR DECLARED SCALARS
* OR THEIR SUBRANGES WITH BOUNDARY CHECKS
*
* - READSTR : READ A 'STRING' AS DEFINED IN THE NON-STANDARD
* STRING PACKAGE. NOT NEEDED IF THE PACKAGE IS
* DEACTIVATED.
*
* NOTICE THAT, TO AVOID EATING MORE CHARACTERS THAN NEEDED,
* THE PROCEDURES ARE USING NEXTCH, THAT WORKS LIKE READ,
* BUT BACKWARDS, THAT IS, IT FIRST GETS AND THEN ASSIGNS.
*
************************************************************************************)
CONST
maxset = 71;
offset = 40B;
maxstrlen = 135;
TYPE
setrange = 0..maxset;
vector = ↑name_vector;
name_vector = ARRAY[0..0] OF alfa;
standard_set = SET OF setrange;
scalar_form = (integer_form,char_form,real_form,bool_form,declared_form,sstring_form);
error_form = (nonalpha,undefined,outofrange,doublydef,nonnumeric,openquote,
doublequote,closequote,twoperiods,openbracket,
closebracket,endoffile,endofline,toolongstr);
string = RECORD
strtext: PACKED ARRAY[1..maxstrlen] OF char;
len: 0..maxstrlen;
END;
VAR
type_name: PACKED ARRAY[scalar_form,1..7] OF char;
errormessage: PACKED ARRAY[error_form,1..25] OF char;
ch: char;
set_flag, direct_call, error_exit: boolean;
identifier: alfa;
INITPROCEDURE;
BEGIN
type_name[integer_form] := 'INTEGER';
type_name[char_form] := 'CHAR ';
type_name[real_form] := 'REAL ';
type_name[bool_form] := 'BOOLEAN';
type_name[declared_form] := 'SCALAR ';
type_name[sstring_form] := 'STRING ';
errormessage[nonalpha ] := 'STARTS WITH NONALPHABETIC';
errormessage[undefined ] := 'UNDEFINED OR OUT OF RANGE';
errormessage[outofrange ] := 'VALUE OUT OF THE RANGE ';
errormessage[doublydef ] := 'SET ELEMENT APPEARS TWICE';
errormessage[nonnumeric ] := 'IT STARTS WITH NONNUMERIC';
errormessage[openquote ] := 'OPENING QUOTE EXPECTED ';
errormessage[doublequote ] := 'QUOTE SHOULD BE DOUBLE ';
errormessage[closequote ] := 'CLOSING QUOTE EXPECTED ';
errormessage[twoperiods ] := 'TWO PERIODS EXPECTED ';
errormessage[openbracket ] := 'OPENING BRACKET EXPECTED ';
errormessage[closebracket] := ''','',''..'' OR '']'' EXPECTED ';
errormessage[endoffile ] := 'READ ATTEMPTED BEYOND EOF';
errormessage[endofline ] := 'EOLINE WHEN CHAR EXPECTED';
errormessage[toolongstr ] := 'LINE EXCEEDS MAX LENGTH, ';
direct_call := true; error_exit := false; set_flag := false;
END;
(** STOP ERROR NEXTCH SKIP READIRANGE READCRANGE READRRANGE **)
PROCEDURE stop; EXTERN;
PROCEDURE wrtfnm(VAR source_file: text); EXTERN;
PROCEDURE writefilename(VAR source_file: text);
BEGIN (*WRITEFILENAME*)
error_exit := false;
write(tty,' IN FILE ');
break(tty);
wrtfnm(source_file);
END (*WRITEFILENAME*);
PROCEDURE error( errornumber: error_form; type_form: scalar_form);
BEGIN (*ERROR*)
IF NOT error_exit THEN
BEGIN
writeln(tty);
write(tty,'%? INPUT ERROR: READING A ');
IF set_flag THEN
write(tty,'SET OF ');
IF type_form <> sstring_form THEN
write(tty,'SUBRANGE OF ');
writeln(tty,type_name[type_form],' :');
write(tty,' ':8);
error_exit := true
END;
write(tty,errormessage[errornumber]);
break(tty);
END (*ERROR*);
PROCEDURE nextch( VAR source_file: text);
BEGIN (*NEXTCH*)
get(source_file);
ch := source_file↑;
END (*NEXTCH*);
PROCEDURE skip( VAR source_file: text);
BEGIN (*SKIP*)
ch := source_file↑;
LOOP
WHILE (ch = ' ') AND NOT eoln(source_file) DO
nextch(source_file);
EXIT IF (ch <> ' ') OR eof(source_file);
readln(source_file);
ch := source_file↑;
END
END (*SKIP*);
PROCEDURE readirange( VAR source_file: text;
VAR source_value: integer;
min_value, max_value: integer);
VAR
negative: boolean;
BEGIN (*READIRANGE*)
IF direct_call THEN skip(source_file);
negative := false; source_value := 0;
IF ch IN ['+','-'] THEN
BEGIN
negative := ch = '-';
nextch(source_file)
END;
IF NOT (ch IN ['0'..'9']) THEN
BEGIN
error(nonnumeric,integer_form);
writeln(tty,' ***',ch,'***');
write(tty,' ':7);
END;
WHILE ch IN ['0'..'9'] DO
BEGIN
source_value := source_value * 10 + (ord(ch) - ord('0'));
nextch(source_file)
END;
IF NOT error_exit THEN
BEGIN
IF negative THEN
source_value := - source_value;
IF (source_value < min_value) OR (source_value > max_value) THEN
BEGIN
error(outofrange,integer_form);
writeln(tty,' ',min_value,'..',max_value,' ***',source_value,'***');
write(tty,' ':7);
END;
END;
IF direct_call AND error_exit THEN
BEGIN
writefilename(source_file);
stop
END
ELSE
direct_call := true
END (*READIRANGE*);
PROCEDURE readcrange( VAR source_file: text;
VAR source_value: char;
min_value, max_value: char);
BEGIN (*READCRANGE*);
IF eoln(source_file) THEN
BEGIN
IF NOT direct_call THEN
BEGIN
error(endofline,char_form);
writeln(tty);
write(tty,' ':7);
END
ELSE
BEGIN
readln(source_file);
ch := source_file↑;
END;
END;
IF NOT error_exit THEN
BEGIN
source_value := source_file↑;
get(source_file);
IF (source_value < min_value) OR (source_value > max_value) THEN
BEGIN
error(outofrange,char_form);
writeln(tty,' ''',min_value,'''..''',max_value,''' ***''',source_value,'''***');
write(tty,' ':7);
END;
END;
IF direct_call AND error_exit THEN
BEGIN
writefilename(source_file);
stop
END
ELSE
direct_call := true
END (*READCRANGE*);
PROCEDURE readrrange( VAR source_file: text;
VAR source_value: real;
min_value, max_value: real);
BEGIN (*READRRANGE*)
skip(source_file);
read(source_file,source_value);
IF (source_value < min_value) OR (source_value > max_value) THEN
BEGIN
error(outofrange,real_form);
writeln(tty,' ',min_value,'..',max_value);
write(tty,' ':8,'***',source_value,'***');
IF direct_call THEN
BEGIN
writefilename(source_file);
stop
END
END;
direct_call := true
END (*READRRANGE*);
(** READSCALAR READIDENTIFIER READSET **)
PROCEDURE readscalar( VAR source_file: text;
VAR source_value: integer;
min_value, max_value: integer;
scalar_name: vector);
PROCEDURE readidentifier;
VAR
i: integer;
BEGIN (*READIDENTIFIER*)
identifier := ' '; i := 0;
IF NOT (ch IN ['A'..'Z']) THEN
BEGIN
error(nonalpha,declared_form);
writeln(tty,'. SUBRANGE IS ',scalar_name↑[min_value],'..',scalar_name↑[max_value]);
write(tty,'***':11,ch,'***');
END
ELSE
REPEAT
IF i < alfalength THEN
BEGIN
i := i + 1;
identifier[i] := ch;
END;
nextch(source_file)
UNTIL NOT (ch IN ['0'..'9','A'..'Z','_']);
END (*READIDENTIFIER*);
BEGIN (*READSCALAR*)
IF direct_call THEN skip(source_file);
readidentifier;
IF NOT error_exit THEN
BEGIN
source_value := min_value;
WHILE (scalar_name↑[-source_value] <> identifier) AND NOT error_exit DO
IF source_value < max_value THEN source_value := source_value+1
ELSE
BEGIN
error(undefined,declared_form);
writeln(tty,' ',scalar_name↑[-min_value],'..',
scalar_name↑[-max_value],' ***',identifier,'***');
write(tty,' ':7);
END;
END;
IF direct_call AND error_exit THEN
BEGIN
writefilename(source_file);
stop
END
ELSE
direct_call := true
END (*READSCALAR*);
PROCEDURE readset( VAR source_file: text;
VAR set_variable: standard_set;
min_value, max_value: integer;
scalar_name: vector;
element_form: scalar_form);
LABEL
111;
VAR
scalar_value: RECORD
CASE scalar_form OF
integer_form: (ival: integer);
char_form : (cval: char)
END;
i, first_scalar: integer;
subrange: boolean;
BEGIN (*READSET*)
set_flag := true;
subrange := false;
first_scalar := 0;
set_variable := [];
skip(source_file);
IF max_value = 0 THEN max_value := maxset;
IF NOT eof(source_file) THEN
BEGIN
IF ch = '[' THEN
BEGIN
nextch(source_file);
skip(source_file);
IF ch <> ']' THEN
LOOP
direct_call := false;
CASE element_form OF
integer_form:
readirange(source_file,scalar_value.ival,min_value,max_value);
char_form:
BEGIN
IF ch <> '''' THEN
BEGIN
error(openquote,char_form);
writeln(tty,'***',ch,'***');
write(tty,' ':7);
END
ELSE
BEGIN
readcrange(source_file,scalar_value.cval,chr(min_value),chr(max_value));
IF scalar_value.cval = '''' THEN
BEGIN
nextch(source_file) ;
IF ch <> '''' THEN
BEGIN
error(doublequote,char_form);
writeln(tty,'***''''',ch,'''***');
write(tty,' ':7);
END;
END ;
nextch(source_file);
IF NOT error_exit THEN
IF ch <> '''' THEN
BEGIN
error(closequote,char_form);
write(tty,'***''',scalar_value.cval);
IF scalar_value.cval = '''' THEN
write(tty,'''');
writeln(tty,ch,'***');
write(tty,' ':7);
END
ELSE nextch(source_file);
scalar_value.ival := scalar_value.ival-offset;
END
END;
declared_form:
readscalar(source_file,scalar_value.ival,min_value,max_value,scalar_name)
END (*CASE ELEMENT_FORM*);
IF NOT error_exit THEN
BEGIN
IF scalar_value.ival IN set_variable THEN
BEGIN
error(doublydef,element_form); write(tty,' ***');
CASE element_form OF
integer_form:
write(tty,scalar_value.ival);
char_form:
BEGIN
IF scalar_value.ival + offset = ord('''') THEN write(tty,'''') ;
write(tty,'''',chr(scalar_value.ival+offset),'''');
END ;
declared_form:
write(tty,identifier)
END;
writeln(tty,'***');
write(tty,' ':7);
END
ELSE (*NOT(SCALAR_VALUE.IVAL IN SET_VARIABLE)*)
IF subrange THEN
FOR i := first_scalar+1 TO scalar_value.ival DO
set_variable := set_variable + [ i ]
ELSE
set_variable := set_variable + [ scalar_value.ival ];
IF (ch = ' ') THEN skip(source_file)
END;
subrange := false;
EXIT IF NOT (ch IN [',','.',':']) OR error_exit;
IF ch IN ['.',':'] THEN
BEGIN
IF ch = '.' THEN
BEGIN
nextch(source_file);
IF ch <> '.' THEN
BEGIN
error(twoperiods,element_form);
writeln(tty,'***.',ch,'***');
write(tty,' ');
GOTO 111
END
END;
subrange := true;
first_scalar := scalar_value.ival
END;
nextch(source_file);
skip(source_file);
END (*LOOP*);
111:
direct_call := true;
IF NOT error_exit THEN
IF (ch <> ']') THEN
BEGIN
error(closebracket,element_form);
writeln(tty,'***',ch,'***');
write(tty,' ':7);
END
else
nextch(source_file);
END
ELSE (*CH <> '['*)
BEGIN
error(openbracket,element_form);
writeln(tty,'***',ch,'***');
write(tty,' ':7);
END;
IF error_exit AND eof(source_file) THEN
error(endoffile,element_form);
END
ELSE (* EOF(SOURCE_FILE) *)
error(endoffile,element_form);
set_flag := false;
END (*READSET*);
(** READISET READCSET READDSET **)
PROCEDURE readiset( VAR source_file: text;
VAR set_variable: standard_set;
min_value, max_value: integer);
BEGIN (*READISET*)
readset(source_file,set_variable,min_value,max_value,NIL,integer_form);
IF error_exit THEN
BEGIN
writefilename(source_file);
stop
END
END (*READISET*);
PROCEDURE readcset( VAR source_file: text;
VAR set_variable: standard_set;
min_value, max_value: integer);
BEGIN (*READCSET*)
readset(source_file,set_variable,min_value,max_value,NIL,char_form);
IF error_exit THEN
BEGIN
writefilename(source_file);
stop
END
END (*READCSET*);
PROCEDURE readdset( VAR source_file: text;
VAR set_variable: standard_set;
min_value, max_value: integer;
scalar_name: vector);
BEGIN (*READDSET*)
readset(source_file,set_variable,min_value,max_value,scalar_name,declared_form);
IF error_exit THEN
BEGIN
writefilename(source_file);
stop
END
END (*READDSET*);
(**********************************************************************
*
* PROCEDURE READSTR
*
* - READS A STRING S FROM THE FILE STRINP.
* THE STRING STARTS IN THE CURRENT CHARACTER, AND ENDS
* WHEN A CRLF IS FOUND. IF THERE ARE MORE THAN 135
* CHARACTERS BEFORE THE CRLF, THEY ARE FLUSHED.
* AN ERROR MESSAGE IS ISUED, BUT EXECUTION CONTINUES.
*
* READSTR IS PART OF THE PASREL RUNTIME-SUPPORT.
* A CALL TO READSTR IS GENERATED EACH TIME A VARIABLE OF
* THE NON-STANDARD TYPE STRING IS FOUND AS A PARAMETER TO
* PROCEDURES READ OR READLN.
*
*********************************************************************)
PROCEDURE readstr(VAR source_file: text; VAR string_variable: string);
VAR
ch: char;
BEGIN (*READSTR*)
IF eoln(source_file) THEN
BEGIN
readln(source_file);
ch := source_file↑;
END;
WITH string_variable DO
BEGIN
len:=0;
WHILE (NOT eoln(source_file)) AND (len < maxstrlen) DO
BEGIN
len:=len+1;
strtext[len]:=source_file↑;
get (source_file);
END;
END;
IF NOT eoln(source_file) THEN (* DISCARD EXCEEDING CHARS *)
BEGIN
error(toolongstr,sstring_form);
writeln(tty,maxstrlen:4,' CHARACTERS. REST OF LINE FLUSHED. EXECUTION CONTINUED');
write(tty,'***':11);
WHILE NOT eoln (source_file) DO
BEGIN
write(tty,source_file↑);
get(source_file);
END;
write(tty,'***');
break(tty);
writefilename(source_file);
END;
END (* READSTR *);
BEGIN
END.
PROGRAM write, wrtscalar, wrtiset, wrtcset, wrtdset;
(************************************************************************************
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG 13
* GERMANY
* 1976
*
* PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
*
* EXTENDED FORMATTED OUTPUT
*
* - WRTSCALAR : WRITE IDENTIFIERS OF DECLARED SCALARS
*
* - WRTISET,
* WRTCSET,
* WRTDSET : WRITE SETS OF INTEGER, CHAR OR DECLARED SCALARS
* OR THEIR SUBRANGES
*
************************************************************************************)
CONST
maxset = 71;
offset = 40B;
halfword = 777777B;
intstdlgth = 12;
TYPE
halfrange = 0..halfword;
setrange = 0..maxset;
vector = ↑name_vector;
name_vector = ARRAY[0..0] OF alfa;
standard_set = SET OF setrange;
scalar_form = (integer_form,char_form,real_form,bool_form,declared_form);
pair = PACKED RECORD
value: halfrange;
length: halfrange
END;
VAR
direct_call: boolean;
INITPROCEDURE;
BEGIN
direct_call := true
END;
(** WRTSCALAR WRTSET WRTISET WRTCSET WRTDSET **)
PROCEDURE wrtscalar( VAR target_file: text;
scalar_value: integer;
maximum: pair;
scalar_name: vector);
VAR
i: integer;
BEGIN
IF (scalar_value >= 0) AND (scalar_value <= maximum.value) THEN
WITH maximum DO
BEGIN
IF length=0 THEN length:=10 (*DEFAULT FORMAT*);
i := 0;
WHILE scalar_name↑[-scalar_value,i+1] <> ' ' DO i := i + 1;
IF length < i THEN write(target_file,scalar_name↑[-scalar_value]:length)
ELSE BEGIN
write(target_file,' ':(length-i));
write(target_file,scalar_name↑[-scalar_value]:i)
END
END
ELSE
write(target_file,'**********');
direct_call := true
END;
PROCEDURE wrtset( VAR target_file: text;
set_value: standard_set;
maximum: pair;
scalar_name: vector;
element_form: scalar_form);
VAR
element: setrange;
first_element, subrange: boolean;
BEGIN
write(target_file,'[');
first_element := true;
subrange := false;
element := 0;
WHILE element <= maxset DO
BEGIN
IF element IN set_value THEN
BEGIN
IF NOT (first_element OR subrange) THEN write(target_file,',');
first_element := false;
subrange := false;
direct_call := false;
WITH maximum DO
CASE element_form OF
integer_form:
BEGIN
IF length <= 0 THEN length := intstdlgth;
write(target_file,element:length)
END;
char_form:
BEGIN
IF length > 3 THEN
IF (element + offset) = ord('''') THEN write(target_file,' ':(length-4),'''')
ELSE write(target_file,' ':(length-3));
write(target_file,'''',chr(element+offset),'''')
END;
declared_form:
wrtscalar(target_file,element,maximum,scalar_name)
END;
IF (element+1 IN set_value) AND (element+2 IN set_value) THEN
BEGIN
WHILE element+2 IN set_value DO
element := element + 1;
subrange := true;
write(target_file,'..')
END
END;
element := element + 1
END;
write(target_file,']');
direct_call := true
END;
PROCEDURE wrtiset( VAR target_file: text;
set_value: standard_set;
maximum: pair);
BEGIN
wrtset(target_file,set_value,maximum,NIL,integer_form)
END;
PROCEDURE wrtcset( VAR target_file: text;
set_value: standard_set;
maximum: pair);
BEGIN
wrtset(target_file,set_value,maximum,NIL,char_form)
END;
PROCEDURE wrtdset( VAR target_file: text;
set_value: standard_set;
maximum: pair;
scalar_name: vector);
BEGIN
wrtset(target_file,set_value,maximum,scalar_name,declared_form)
END;
BEGIN
END.
PROGRAM timing, setruntime, setelapsedtime, settime, runtime, elapsedtime,
timereport;
(*******************************************************************
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* PACKAGE OF PROCEDURES TO KEEP AND REPORT RUNTIME AND ELAPSED
* TIME. THE TIME PERIOD THAT THEY REPORT IS THAT TRANSCURRED
* BETWEEN THE CALLS TO SETRUNTIME AND RUNTIME (CORR SETELAPSEDTIME
* AND ELAPSEDTIME) OR BETWEEN TWO CALLS TO RUNTIME (CORR ELAPSEDTIME)
*
*********************************************************************)
VAR
cputime : ARRAY[0..3] OF integer;
clocktime : ARRAY[0..4] OF integer;
ttyout: text;
PROCEDURE setruntime;
BEGIN (* SETRUNTIME *)
cputime[0] := clock;
END (* SETRUNTIME *);
PROCEDURE setelapsedtime;
BEGIN (* SETELAPSEDTIME *)
clocktime[0] := realtime;
END (* SETELAPSEDTIME *);
PROCEDURE settime;
BEGIN (* SETTIME *)
setruntime;
setelapsedtime;
END (* SETTIME *);
PROCEDURE runtime (VAR buffer: alfa);
(* RETURNS THE TRANSCURRED CPUTIME IN THE FORMAT 'MM:SS:MMM ' *)
VAR
temptime, j, i: integer;
BEGIN (* RUNTIME *)
temptime := clock;
cputime[0] := temptime - cputime[0];
cputime[1] := cputime[0] DIV 60000;
cputime[2] := (cputime[0] MOD 60000) DIV 1000;
cputime[3] := cputime[0] MOD 1000;
cputime[0] := temptime;
buffer := ' : . ';
buffer[7] := chr(cputime[3] DIV 100 + ord ('0'));
j := 1;
FOR i := 1 TO 3 DO
BEGIN
buffer[j] := chr((cputime[i] MOD 100)DIV 10 + ord('0'));
buffer[j + 1] := chr(cputime[i] MOD 10 + ord('0'));
j := j + 3 + j DIV 4;
END;
END (* RUNTIME *);
PROCEDURE elapsedtime (VAR buffer: alfa);
(* RETURNS THE ELAPSED TIME IN THE FORMAT 'HH:MM:SS.D' *)
VAR
temptime, i, j: integer;
BEGIN (* ELAPSEDTIME *)
temptime := realtime;
clocktime[0] := temptime - clocktime[0];
clocktime[1] := clocktime[0] DIV 3600000;
clocktime[2] := (clocktime[0] MOD 3600000) DIV 60000;
clocktime[3] := (clocktime[0] MOD 60000) DIV 1000;
clocktime[4] := (clocktime[0] MOD 1000) DIV 100
+ (clocktime[0] MOD 100) DIV 50;
IF clocktime[4] = 10 THEN
BEGIN
clocktime[3] := clocktime[3] + 1;
clocktime[4] := 0;
END;
clocktime[0] := temptime;
buffer := ' : : . ';
j := 1;
FOR i := 1 TO 3 DO
BEGIN
buffer[j] := chr(clocktime[i] DIV 10 + ord('0'));
buffer[j + 1] := chr(clocktime[i] MOD 10 + ord('0'));
j := j + 3;
END;
buffer[10] := chr(clocktime[4] MOD 10 + ord('0'));
END (* ELAPSEDTIME *);
PROCEDURE timereport (VAR ttyout: text; header: alfa);
(* WRITES ONTO FILE TTYOUT THE CPU AND ELAPSED TIME *)
VAR
buffer1, buffer2 : alfa;
BEGIN (* TIMEREPORT *)
runtime (buffer1);
elapsedtime (buffer2);
writeln(ttyout);
IF header <> ' ' THEN
write(ttyout,header,' ');
writeln(ttyout,'RUNTIME: ',buffer1,' ELAPSED: ',buffer2);
break(ttyout);
END (* TIMEREPORT *);
BEGIN
END.
PROGRAM strings, assign, length, pos, substr, concat, getchr, putchar,
strlt, strle, streq, strge, strgt, strne, wrtstr, wrtst1;
(**********************************************************************
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* PASCAL NON-STANDARD STRING PACKAGE (14-SEPT-78)
*
* A PACKAGE OF SUBROUTINES TO SUPPORT VARIABLE-LENGTH STRING
* VARIABLES IN PASCAL. THEIR CALLING DOES NOT FOLLOW THE
* STANDARD TYPE-CHECKING RESTRICTIONS IN PASCAL. THE COMPILER
* NEEDS TO KNOW ABOUT THEM AND TREAT THEIR PARAMETERS IN A
* SPECIAL WAY.
*
* - ASSIGN CREATE A STRING
*
* - LENGTH, POS RETURN INFORMATION ON THE STRING
*
* - SUBSTR, CONCAT,
* getchr, PUTCHAR MOVE AROUND PARTS OF STRINGS
*
* - STRLT, STRLE, STREQ,
* STRGE, STRGT, STRNE COMPARE TWO STRINGS
*
* - WRTSTR, WRTST1 WRITE A STRING
*
* - READSTR READ THE REST OF THE LINE AS A STRING.
* IT IS WITH THE OTHER READ PROCEDURES.
*
* N. B.: SUBSTR, getchr AND PUTCHAR CONTAIN CODE FOR BOUNDARY
* CHECKING OF THE START POSITION, WHICH WILL BE SUPERFLUOUS
* WHEN CHECKING FOR PARAMETER PASSING IS IMPLEMENTED.
*
*********************************************************************)
CONST
maxstrlen = 135;
checkstrlen = 137;
TYPE
strgrange = 1..maxstrlen;
strgrange0 = 0..maxstrlen;
string = RECORD
strtext: PACKED ARRAY [1..maxstrlen] OF char;
len: strgrange0;
END;
strgrangeneg = 0..checkstrlen;
error_form = (outofrange, outofstring);
var_form = (src_var, dest_var, final_pos);
pack7 = PACKED ARRAY[1..7] OF char;
VAR
error_exit: boolean;
errormessage: PACKED ARRAY[var_form,1..26] OF char;
direct_call: boolean;
procname: pack7;
INITPROCEDURE;
BEGIN
error_exit := false; direct_call := true;
errormessage[src_var] := 'START SOURCE POSITION ';
errormessage[dest_var] := 'START DESTINATION POSITION';
errormessage[final_pos] := 'FINAL DESTINATION POSITION';
END;
PROCEDURE stop; EXTERN;
PROCEDURE errinstr(errornumber: error_form; problemvar: var_form;
value, limit: integer);
BEGIN (*ERRINSTR*)
IF errornumber = outofrange THEN
write(tty,' OUT OF THE VALID RANGE 1..')
ELSE
BEGIN
write(tty,' GREATER THAN STRING LENGTH ');
IF problemvar = dest_var THEN
write(tty,'+ 1,');
END;
writeln(tty,limit:4,' ***',value,'***');
write(tty,' WHEN CALLING ',procname,' ');
break(tty);
error_exit := true;
END (*ERRINSTR*);
PROCEDURE checklength(VAR here: string; VAR length: strgrangeneg);
VAR
kludge : PACKED RECORD
CASE boolean OF
true: (str: string);
false: (bit: PACKED ARRAY[0..35] OF 0..1);
END;
i: 0..35;
BEGIN (*CHECKLENGTH*)
IF length = checkstrlen THEN
BEGIN
kludge.str := here;
FOR i := 0 TO 6 DO
kludge.bit[i] := kludge.bit[i + 29];
here := kludge.str;
length := 1
END
ELSE
IF length > maxstrlen THEN
length := here.len;
END (*CHECKLENGTH*);
(**********************************************************************
*
* PROCEDURE ASSIGN
*
* - ASSIGNS THE STRING DEST FROM THE PACKED ARRAY OF CHAR SRC.
* THE COMPILER WILL ALLOW SRC TO BE OF ANY LENGTH.
*
* ASSIGN IS A PRE-DECLARED PROCEDURE
* AVAILABLE TO EVERY PASCAL USER.
*
*********************************************************************)
PROCEDURE assign(src: string; VAR dest: string; srclen: strgrange0);
VAR
i: integer;
BEGIN (* ASSIGN *)
checklength(src,srclen);
dest.len:=srclen;
FOR i:=1 TO srclen DO dest.strtext[i]:=src.strtext[i];
END (* ASSIGN *);
(**********************************************************************
*
* FUNCTION LENGTH
*
* - RETURNS THE LENGTH OF THE STRING SRC
*
* LENGTH IS A PRE-DECLARED PROCEDURE
* AVAILABLE TO EVERY PASCAL USER.
*
*********************************************************************)
FUNCTION length(src: string; srclen: strgrangeneg): strgrange0;
BEGIN (* LENGTH *)
checklength(src, srclen);
length:=srclen;
END (* LENGTH *);
(**********************************************************************
*
* FUNCTION POS
*
* - RETURNS THE STARTING POSITION OF THE FIRST OCCURRENCE OF THE
* STRING S1 IN THE STRING S2. IF THERE IS NO OCURRENCE, 0 IS
* RETURNED.
*
* POS IS A PRE-DECLARED FUNCTION
* AVAILABLE TO EVERY PASCAL USER.
*
*********************************************************************)
FUNCTION pos(s1, s2: string; s1len,s2len: strgrangeneg): strgrange0;
VAR
i, j, k, ind: integer;
matching: boolean;
BEGIN (* POS *)
ind:=0;
i := 1;
checklength(s1,s1len);
checklength(s2,s2len);
WHILE (i <= s2len - s1len + 1) AND (ind = 0) DO
BEGIN
k := i;
j := 1;
matching := true;
WHILE (j <= s1len) AND matching DO
IF s2.strtext[k] = s1.strtext[j] THEN
BEGIN
j := j + 1;
k := k + 1;
END
ELSE
matching := false;
IF matching THEN
ind := i
ELSE
i := i + 1;
END;
pos := ind;
END (* POS *);
(**********************************************************************
*
* PROCEDURE SUBSTR
*
* - COPIES AT MOST LENG CHARACTERS FROM STRING SRC TO STRING DEST,
* STARTING AT POSITION SRCPOS IN SRC, DESTPOS IN DEST. DEST.LEN
* WILL BE CHANGED IF NEEDED. IF SRCPOS + LENG IS TOO LONG,
* ONLY (SRC.LEN - SRCPOS + 1) CHARACTERS WILL BE COPIED.
* IF DESTPOS + LENG - 1 > MAXSTRLEN, ERROR.
* IF SRCPOS OR DESTPOS IS OUTSIDE THE STRING, ERROR.
*
* SUBSTR IS A PRE-DECLARED PROCEDURE
* AVAILABLE TO EVERY PASCAL USER.
*
*********************************************************************)
PROCEDURE substr(src: string; VAR dest: string;
srcpos, destpos, leng: strgrange; srclen: strgrangeneg);
VAR
idest, isrc, netsrcleng, destlast, lastlast: integer;
BEGIN (*SUBSTR*)
IF leng > 0 THEN
BEGIN
IF direct_call THEN
procname := 'SUBSTR ';
checklength(src,srclen);
IF (srcpos < 1) OR (srcpos > maxstrlen) THEN
errinstr(outofrange,src_var,srcpos,maxstrlen)
ELSE
IF (destpos < 1) OR (destpos > maxstrlen) THEN
errinstr(outofrange,dest_var,destpos,maxstrlen)
ELSE
IF srcpos > srclen THEN
errinstr(outofstring,src_var,srcpos,srclen)
ELSE
IF destpos > dest.len + 1 THEN
errinstr(outofstring,dest_var,destpos,dest.len + 1)
ELSE
IF (destpos + leng - 1) > maxstrlen THEN
errinstr(outofstring,final_pos,destpos+srclen-1,maxstrlen);
IF error_exit THEN
IF direct_call THEN
BEGIN
error_exit := false;
stop
END
ELSE
ELSE (* NO BOUNDS ERRORS *)
BEGIN
netsrcleng := min (leng, srclen + 1 - srcpos);
destlast := destpos + netsrcleng - 1;
isrc := srcpos;
FOR idest := destpos TO destlast DO
BEGIN
dest.strtext[idest] := src.strtext[isrc];
isrc := isrc + 1;
END;
IF destlast > dest.len THEN
dest.len := destlast;
END
END
END (* SUBSTR*);
(**********************************************************************
*
* PROCEDURE CONCAT
*
* - COPIES STRING S1 TO THE END OF STRING S2
* S1 IS NOT AFFECTED
*
* CONCAT IS A PREDEFINED PROCEDURE
* AVAILABLE TO EVERY PASCAL USER.
*********************************************************************)
PROCEDURE concat (src: string; VAR dest: string; srclen: strgrangeneg);
BEGIN (*CONCAT*)
direct_call := false;
procname := 'CONCAT ';
checklength(src,srclen);
substr(src,dest,1,dest.len+1,srclen,srclen);
IF error_exit THEN
BEGIN
direct_call := true;
error_exit := false;
stop
END;
END (*CONCAT*);
(**********************************************************************
*
* FUNCTION getchr
*
* - RETURN THE CHARACTER CONTAINED IN POSITION SRCPOS OF STRING SRC.
* IF SRCPOS FALLS OUT OF THE VALID STRING, ERRINSTR.
*
* this procedure is known to the user as getchar. the name was
* modified to avoid a naming conflict with the sail runtime library.
* (6-sep-79. arr.)
*
* getchr IS A PRE-DECLARED FUNCTION
* AVAILABLE TO EVERY PASCAL USER.
*
*********************************************************************)
FUNCTION getchr (src: string; srcpos: strgrange; srclen: strgrangeneg): char;
VAR
ch: char;
BEGIN (* getchr *)
procname := 'GETCHAR';
checklength(src,srclen);
IF (srcpos < 1) OR (srcpos > maxstrlen) THEN
errinstr(outofrange,src_var,srcpos,maxstrlen)
ELSE
IF srcpos > srclen THEN
errinstr(outofstring,src_var,srcpos,srclen);
IF error_exit THEN
BEGIN
error_exit := false;
stop
END
ELSE
getchr := src.strtext[srcpos];
END (* getchr *);
(**********************************************************************
*
* PROCEDURE PUTCHAR
*
* - PUTS THE CHARACTER SRC AT POSITION DESTPOS IN STRING DEST.
* IF DESTPOS > DEST.LEN, ERROR
*
* PUTCHAR IS A PRE-DECLARED PROCEDURE
* AVAILABLE TO EVERY PASCAL USER.
*
*********************************************************************)
PROCEDURE putchar (src: char; VAR dest: string; destpos: strgrange);
BEGIN (* PUTCHAR *)
procname := 'PUTCHAR';
IF (destpos < 1) OR (destpos > maxstrlen) THEN
errinstr(outofrange,dest_var,destpos,maxstrlen)
ELSE
IF destpos > dest.len + 1 THEN
errinstr(outofstring,dest_var,destpos,dest.len + 1);
IF error_exit THEN
BEGIN
error_exit := false;
stop;
END
ELSE
BEGIN
dest.strtext[destpos] := src;
IF destpos > dest.len THEN
dest.len := destpos;
END
END (* PUTCHAR *);
(**********************************************************************
*
* FUNCTIONS TO COMPARE STRINGS: STRLT, STRLE, STREQ,
* STRGE, STRGT, STRNE
*
* - EACH ONE RETURNS THE RESULT OF THE COMPARISON OF STRINGS
* S1 AND S2, ACCORDING TO THE LAST TWO LETTERS OF ITS NAME.
*
* A STRING S1 IS EQUAL TO S2 IF
* 1. THEY ARE OF THE SAME LENGTH, AND
* 2. THEIR CHARACTERS ARE EQUAL IN EVERY POSITION.
*
* A STRING S1 IS GREATER THAN S2 IF
* 1. THEIR CHARACTERS ARE EQUAL IN POSITIONS 1, ..., X-1
* AND S1 HAS A CHARACTER GREATER IN THE COLLATING
* SEQUENCE IN POSITION X, OR
* 2. THEIR CHARACTERS ARE EQUAL IN POSITIONS 1, ...,
* S2.LEN, AND S1.LEN > S2.LEN.
*
* THEY ARE ALL PRE-DECLARED FUNCTIONS
* AVAILABLE TO EVERY PASCAL USER.
*
*********************************************************************)
FUNCTION strgt(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
VAR
i, tmin: integer;
answer: boolean;
BEGIN (* STRGT *)
checklength(s1,s1len);
checklength(s2,s2len);
tmin:= min(s1len, s2len);
answer := false;
i := 1;
WHILE (i <= tmin) AND (s1.strtext[i] = s2.strtext[i]) DO
i := i + 1;
IF i <= s1len THEN
IF i <= s2len THEN
answer := s1.strtext[i] > s2.strtext[i]
ELSE
answer := true;
strgt := answer;
END (* STRGT *);
FUNCTION strge(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
BEGIN (*STRGE*)
strge := NOT strgt(s2, s1, s2len, s1len);
END (*STRGE*);
FUNCTION streq(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
VAR
i, tmin: integer;
answer: boolean;
BEGIN (* STREQ *)
checklength(s1,s1len);
checklength(s2,s2len);
IF s1len <> s2len THEN
answer := false
ELSE
BEGIN
answer := true;
i := 1;
WHILE (i <= s1len) AND answer DO
BEGIN
IF s1.strtext[i] <> s2.strtext[i] THEN
answer := false;
i := i + 1;
END;
END;
streq := answer;
END (* STREQ *);
FUNCTION strle(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
BEGIN (*STRLE*)
strle := NOT strgt(s1, s2, s1len, s2len);
END (*STRLE*);
FUNCTION strlt(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
BEGIN (*STRLT*)
strlt := strgt(s2, s1, s2len, s1len);
END (*STRLT*);
FUNCTION strne(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
BEGIN (*STRNE*)
strne := NOT streq(s1, s2, s1len, s2len);
END (*STRNE*);
PROCEDURE wrtstr(VAR dest_file:text; src: string; totallength: integer);
BEGIN (*WRTSTR*)
write(dest_file,src.strtext:totallength);
END (*WRTSTR*);
PROCEDURE wrtst1(VAR dest_file:text; src: string; totallength: integer);
BEGIN (*WRTST1*)
write(dest_file,src.strtext:src.len);
END (*WRTST1*);
BEGIN
END.
PROGRAM dumper, dpcnts;
(**********************************************************************
*
* (C) COPYRIGHT 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1979,
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* AUXILIARY ROUTINES FOR STATEMENT COUNTS (PROFILE)
* AS IMPLEMENTED BY PHILIP WISOFF, FEB-79
*
* DPCNTS:
* DUMPS TO A FILE OF INTEGER THE LINE/PAGE MARKERS AND
* THE COUNTS FOR EACH BASIC BLOCK.
*
*********************************************************************)
TYPE
dfiletype = FILE OF integer;
packed9 = PACKED ARRAY [1..9] OF char;
VAR
dumpfile : dfiletype;
PROCEDURE dpcnts (filename : packed9;startofcounts,endofcounts : integer);
TYPE
linerange = 1..777777B;
pointer = RECORD
CASE boolean OF
true : (location : ↑data);
false : (incloc : linerange);
END;
data = PACKED RECORD
page,line : linerange;
count : integer;
END;
VAR
dataptr : pointer;
countdata : data;
BEGIN (*DPCNTS*)
rewrite(dumpfile,filename); (*OPEN THE FILE*)
WITH dataptr DO BEGIN
dataptr.incloc := startofcounts;
WHILE dataptr.incloc <= endofcounts DO (*FOR EACH COUNT MARKER*)
BEGIN
WITH dataptr DO BEGIN (*DUMP LINE, PAGE AND COUNT*)
dumpfile↑ := location↑.page;
put(dumpfile);
dumpfile↑ := location↑.line;
put(dumpfile);
dumpfile↑ := location↑.count;
put(dumpfile);
END;
dataptr.incloc := dataptr.incloc + 2; (*AND GO TO THE NEXT*)
END;
END;
reset(dumpfile,filename); (*CLOSE THE FILE*)
%3 message('to produce the profile listing, .r pcref'); \
END;
BEGIN
END.
PROGRAM mathruns, psqrt;
(**********************************************************************
*
* (C) COPYRIGHT 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1979,
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* MATHEMATICALLY-ORIENTED RUNTIMES FOR THE PASCAL COMPILER.
*
* PSQRT:
* CHECKS FOR THE PARAMETER TO THE FORTRAN ROUTINE FOR
* SQRT TO BE A POSITIVE REAL NUMBER.
*
*********************************************************************)
PROCEDURE stop; EXTERN;
FUNCTION sqrt(fvalue:real): real; FORTRAN;
FUNCTION psqrt(fvalue: real): real;
BEGIN (*PSQRT*)
IF fvalue < 0 THEN
BEGIN
writeln(tty);
writeln(tty,'%? VALUE ERROR: ATTEMPT TO OBTAIN THE SQUARE ROOT OF A NEGATIVE NUMBER');
writeln(tty,'%? VALUE PASED: ',fvalue);
write(tty,'%? ');
break(tty);
stop;
END
ELSE
psqrt := sqrt(fvalue);
END (*PSQRT*);
BEGIN
END.